summaryrefslogtreecommitdiff
path: root/vim/bundle/slimv/slime
diff options
context:
space:
mode:
authorNick Shipp <nick@shipp.ninja>2017-05-07 09:04:01 -0400
committerNick Shipp <nick@shipp.ninja>2017-05-07 09:04:01 -0400
commitc012f55efda29f09179e921cf148d79deb57616e (patch)
treeff0ad37f22622d51194cab192a2aa4b0106d7ad0 /vim/bundle/slimv/slime
parent4ca8f6608883d230131f8a9e8b6d6c091c516049 (diff)
Much maturering of vim configs
Diffstat (limited to 'vim/bundle/slimv/slime')
-rw-r--r--vim/bundle/slimv/slime/README.md78
-rw-r--r--vim/bundle/slimv/slime/contrib/README.md14
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-arglists.lisp1615
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-asdf.lisp536
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp298
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-clipboard.lisp71
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp1004
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-fuzzy.lisp706
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-hyperdoc.lisp18
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-indentation.lisp140
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-kawa.scm2498
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-larceny.scm176
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-listener-hooks.lisp91
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-macrostep.lisp227
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-media.lisp25
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm882
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-mrepl.lisp162
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-package-fu.lisp65
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-presentation-streams.lisp334
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-presentations.lisp246
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-quicklisp.lisp17
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-r6rs.scm416
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-repl.lisp450
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-sbcl-exts.lisp64
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-snapshot.lisp67
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-sprof.lisp154
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp264
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-util.lisp63
-rw-r--r--vim/bundle/slimv/slime/metering.lisp1213
-rw-r--r--vim/bundle/slimv/slime/nregex.lisp523
-rw-r--r--vim/bundle/slimv/slime/packages.lisp194
-rw-r--r--vim/bundle/slimv/slime/sbcl-pprint-patch.lisp332
-rw-r--r--vim/bundle/slimv/slime/slime.el7501
-rw-r--r--vim/bundle/slimv/slime/start-swank.lisp39
-rw-r--r--vim/bundle/slimv/slime/swank-loader.lisp366
-rw-r--r--vim/bundle/slimv/slime/swank.asd37
-rw-r--r--vim/bundle/slimv/slime/swank.lisp3743
-rw-r--r--vim/bundle/slimv/slime/swank/abcl.lisp847
-rw-r--r--vim/bundle/slimv/slime/swank/allegro.lisp1053
-rw-r--r--vim/bundle/slimv/slime/swank/backend.lisp1536
-rw-r--r--vim/bundle/slimv/slime/swank/ccl.lisp861
-rw-r--r--vim/bundle/slimv/slime/swank/clasp.lisp730
-rw-r--r--vim/bundle/slimv/slime/swank/clisp.lisp930
-rw-r--r--vim/bundle/slimv/slime/swank/cmucl.lisp2470
-rw-r--r--vim/bundle/slimv/slime/swank/corman.lisp583
-rw-r--r--vim/bundle/slimv/slime/swank/ecl.lisp845
-rw-r--r--vim/bundle/slimv/slime/swank/gray.lisp170
-rw-r--r--vim/bundle/slimv/slime/swank/lispworks.lisp1018
-rw-r--r--vim/bundle/slimv/slime/swank/match.lisp242
-rw-r--r--vim/bundle/slimv/slime/swank/mkcl.lisp933
-rw-r--r--vim/bundle/slimv/slime/swank/rpc.lisp162
-rw-r--r--vim/bundle/slimv/slime/swank/sbcl.lisp2044
-rw-r--r--vim/bundle/slimv/slime/swank/scl.lisp1726
-rw-r--r--vim/bundle/slimv/slime/swank/source-file-cache.lisp136
-rw-r--r--vim/bundle/slimv/slime/swank/source-path-parser.lisp239
-rw-r--r--vim/bundle/slimv/slime/xref.lisp2906
56 files changed, 44060 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/README.md b/vim/bundle/slimv/slime/README.md
new file mode 100644
index 0000000..7ef8cd3
--- /dev/null
+++ b/vim/bundle/slimv/slime/README.md
@@ -0,0 +1,78 @@
+[![Build Status](https://img.shields.io/travis/slime/slime/master.svg)](https://travis-ci.org/slime/slime) [![MELPA](http://melpa.org/packages/slime-badge.svg?)](http://melpa.org/#/slime) [![MELPA Stable](http://stable.melpa.org/packages/slime-badge.svg?)](http://stable.melpa.org/#/slime)
+
+Overview
+--------
+
+SLIME is the Superior Lisp Interaction Mode for Emacs.
+
+SLIME extends Emacs with support for interactive programming in Common
+Lisp. The features are centered around slime-mode, an Emacs minor-mode that
+complements the standard lisp-mode. While lisp-mode supports editing Lisp
+source files, slime-mode adds support for interacting with a running Common
+Lisp process for compilation, debugging, documentation lookup, and so on.
+
+For much more information, consult [the manual][1].
+
+
+Quick setup instructions
+------------------------
+
+ 1. [Set up the MELPA repository][2], if you haven't already, and install
+ SLIME using `M-x package-install RET slime RET`.
+
+ 2. Add the following lines to your `~/.emacs` file, filling in in
+ the appropriate filenames:
+
+ ```el
+ ;; Set your lisp system and, optionally, some contribs
+ (setq inferior-lisp-program "/opt/sbcl/bin/sbcl")
+ (setq slime-contribs '(slime-fancy))
+ ```
+
+ 3. Use `M-x slime` to fire up and connect to an inferior Lisp. SLIME will
+ now automatically be available in your Lisp source buffers.
+
+If you'd like to contribute to SLIME, you will want to instead follow
+the manual's instructions on [how to install SLIME via Git][7].
+
+
+Contribs
+--------
+
+SLIME comes with additional contributed packages or "contribs".
+Contribs can be selected via the `slime-contribs` list.
+
+The most-often used contrib is `slime-fancy`, which primarily installs a
+popular set of other contributed packages. It includes a better REPL, and
+many more nice features.
+
+
+License
+-------
+
+SLIME is free software. All files, unless explicitly stated otherwise, are
+public domain.
+
+
+Contact
+-------
+
+If you have problems, first have a look at the list of
+[known issues and workarounds][6].
+
+Questions and comments are best directed to the mailing list at
+`slime-devel@common-lisp.net`, but you have to [subscribe][3] first. The
+mailing list archive is also available on [Gmane][4].
+
+See the [CONTRIBUTING.md][5] file for instructions on how to contribute.
+
+
+
+
+[1]: http://common-lisp.net/project/slime/doc/html/
+[2]: http://melpa.org/#/getting-started
+[3]: http://www.common-lisp.net/project/slime/#mailinglist
+[4]: http://news.gmane.org/gmane.lisp.slime.devel
+[5]: https://github.com/slime/slime/blob/master/CONTRIBUTING.md
+[6]: https://github.com/slime/slime/issues?labels=workaround&state=closed
+[7]: http://common-lisp.net/project/slime/doc/html/Installation.html#Installing-from-Git
diff --git a/vim/bundle/slimv/slime/contrib/README.md b/vim/bundle/slimv/slime/contrib/README.md
new file mode 100644
index 0000000..94fd02f
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/README.md
@@ -0,0 +1,14 @@
+This directory contains source code which may be useful to some Slime
+users. `*.el` files are Emacs Lisp source and `*.lisp` files contain
+Common Lisp source code. If not otherwise stated in the file itself,
+the files are placed in the Public Domain.
+
+The components in this directory are more or less detached from the
+rest of Slime. They are essentially "add-ons". But Slime can also be
+used without them. The code is maintained by the respective authors.
+
+See the top level README.md for how to use packages in this directory.
+
+Finally, the contrib `slime-fancy` is specially noteworthy, as it
+represents a meta-contrib that'll load a bunch of commonly used
+contribs. Look into `slime-fancy.el` to find out which.
diff --git a/vim/bundle/slimv/slime/contrib/swank-arglists.lisp b/vim/bundle/slimv/slime/contrib/swank-arglists.lisp
new file mode 100644
index 0000000..a9357ec
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-arglists.lisp
@@ -0,0 +1,1615 @@
+;;; swank-arglists.lisp --- arglist related code ??
+;;
+;; Authors: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+;; Tobias C. Rittweiler <tcr@freebits.de>
+;; and others
+;;
+;; License: Public Domain
+;;
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (swank-require :swank-c-p-c))
+
+;;;; Utilities
+
+(defun compose (&rest functions)
+ "Compose FUNCTIONS right-associatively, returning a function"
+ #'(lambda (x)
+ (reduce #'funcall functions :initial-value x :from-end t)))
+
+(defun length= (seq n)
+ "Test for whether SEQ contains N number of elements. I.e. it's equivalent
+ to (= (LENGTH SEQ) N), but besides being more concise, it may also be more
+ efficiently implemented."
+ (etypecase seq
+ (list (do ((i n (1- i))
+ (list seq (cdr list)))
+ ((or (<= i 0) (null list))
+ (and (zerop i) (null list)))))
+ (sequence (= (length seq) n))))
+
+(declaim (inline memq))
+(defun memq (item list)
+ (member item list :test #'eq))
+
+(defun exactly-one-p (&rest values)
+ "If exactly one value in VALUES is non-NIL, this value is returned.
+Otherwise NIL is returned."
+ (let ((found nil))
+ (dolist (v values)
+ (when v (if found
+ (return-from exactly-one-p nil)
+ (setq found v))))
+ found))
+
+(defun valid-operator-symbol-p (symbol)
+ "Is SYMBOL the name of a function, a macro, or a special-operator?"
+ (or (fboundp symbol)
+ (macro-function symbol)
+ (special-operator-p symbol)
+ (member symbol '(declare declaim))))
+
+(defun function-exists-p (form)
+ (and (valid-function-name-p form)
+ (fboundp form)
+ t))
+
+(defmacro multiple-value-or (&rest forms)
+ (if (null forms)
+ nil
+ (let ((first (first forms))
+ (rest (rest forms)))
+ `(let* ((values (multiple-value-list ,first))
+ (primary-value (first values)))
+ (if primary-value
+ (values-list values)
+ (multiple-value-or ,@rest))))))
+
+(defun arglist-available-p (arglist)
+ (not (eql arglist :not-available)))
+
+(defmacro with-available-arglist ((var &rest more-vars) form &body body)
+ `(multiple-value-bind (,var ,@more-vars) ,form
+ (if (eql ,var :not-available)
+ :not-available
+ (progn ,@body))))
+
+
+;;;; Arglist Definition
+
+(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
+ provided-args ; list of the provided actual arguments
+ required-args ; list of the required arguments
+ optional-args ; list of the optional arguments
+ key-p ; whether &key appeared
+ keyword-args ; list of the keywords
+ rest ; name of the &rest or &body argument (if any)
+ body-p ; whether the rest argument is a &body
+ allow-other-keys-p ; whether &allow-other-keys appeared
+ aux-args ; list of &aux variables
+ any-p ; whether &any appeared
+ any-args ; list of &any arguments [*]
+ known-junk ; &whole, &environment
+ unknown-junk) ; unparsed stuff
+
+;;;
+;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp,
+;;; and is only used to describe certain arglists that cannot be
+;;; described in another way.
+;;;
+;;; &ANY is very similiar to &KEY but while &KEY is based upon
+;;; the idea of a plist (key1 value1 key2 value2), &ANY is a
+;;; cross between &OPTIONAL, &KEY and *FEATURES* lists:
+;;;
+;;; a) (&ANY :A :B :C) means that you can provide any (non-null)
+;;; set consisting of the keywords `:A', `:B', or `:C' in
+;;; the arglist. E.g. (:A) or (:C :B :A).
+;;;
+;;; (This is not restricted to keywords only, but any self-evaluating
+;;; expression is allowed.)
+;;;
+;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can
+;;; provide any (non-null) set consisting of lists where
+;;; the CAR of the list is one of `key1', `key2', or `key3'.
+;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23))
+;;;
+;;;
+;;; For example, a) let us describe the situations of EVAL-WHEN as
+;;;
+;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body)
+;;;
+;;; and b) let us describe the optimization qualifiers that are valid
+;;; in the declaration specifier `OPTIMIZE':
+;;;
+;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...))
+;;;
+
+;; This is a wrapper object around anything that came from Slime and
+;; could not reliably be read.
+(defstruct (arglist-dummy
+ (:conc-name #:arglist-dummy.)
+ (:constructor make-arglist-dummy (string-representation)))
+ string-representation)
+
+(defun empty-arg-p (dummy)
+ (and (arglist-dummy-p dummy)
+ (zerop (length (arglist-dummy.string-representation dummy)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter +lambda-list-keywords+
+ '(&provided &required &optional &rest &key &any)))
+
+(defmacro do-decoded-arglist (decoded-arglist &body clauses)
+ (assert (loop for clause in clauses
+ thereis (member (car clause) +lambda-list-keywords+)))
+ (flet ((parse-clauses (clauses)
+ (let* ((size (length +lambda-list-keywords+))
+ (initial (make-hash-table :test #'eq :size size))
+ (main (make-hash-table :test #'eq :size size))
+ (final (make-hash-table :test #'eq :size size)))
+ (loop for clause in clauses
+ for lambda-list-keyword = (first clause)
+ for clause-parameter = (second clause)
+ do
+ (case clause-parameter
+ (:initially
+ (setf (gethash lambda-list-keyword initial) clause))
+ (:finally
+ (setf (gethash lambda-list-keyword final) clause))
+ (t
+ (setf (gethash lambda-list-keyword main) clause)))
+ finally
+ (return (values initial main final)))))
+ (generate-main-clause (clause arglist)
+ (dcase clause
+ ((&provided (&optional arg) . body)
+ (let ((gensym (gensym "PROVIDED-ARG+")))
+ `(dolist (,gensym (arglist.provided-args ,arglist))
+ (declare (ignorable ,gensym))
+ (let (,@(when arg `((,arg ,gensym))))
+ ,@body))))
+ ((&required (&optional arg) . body)
+ (let ((gensym (gensym "REQUIRED-ARG+")))
+ `(dolist (,gensym (arglist.required-args ,arglist))
+ (declare (ignorable ,gensym))
+ (let (,@(when arg `((,arg ,gensym))))
+ ,@body))))
+ ((&optional (&optional arg init) . body)
+ (let ((optarg (gensym "OPTIONAL-ARG+")))
+ `(dolist (,optarg (arglist.optional-args ,arglist))
+ (declare (ignorable ,optarg))
+ (let (,@(when arg
+ `((,arg (optional-arg.arg-name ,optarg))))
+ ,@(when init
+ `((,init (optional-arg.default-arg ,optarg)))))
+ ,@body))))
+ ((&key (&optional keyword arg init) . body)
+ (let ((keyarg (gensym "KEY-ARG+")))
+ `(dolist (,keyarg (arglist.keyword-args ,arglist))
+ (declare (ignorable ,keyarg))
+ (let (,@(when keyword
+ `((,keyword (keyword-arg.keyword ,keyarg))))
+ ,@(when arg
+ `((,arg (keyword-arg.arg-name ,keyarg))))
+ ,@(when init
+ `((,init (keyword-arg.default-arg ,keyarg)))))
+ ,@body))))
+ ((&rest (&optional arg body-p) . body)
+ `(when (arglist.rest ,arglist)
+ (let (,@(when arg `((,arg (arglist.rest ,arglist))))
+ ,@(when body-p `((,body-p (arglist.body-p ,arglist)))))
+ ,@body)))
+ ((&any (&optional arg) . body)
+ (let ((gensym (gensym "REQUIRED-ARG+")))
+ `(dolist (,gensym (arglist.any-args ,arglist))
+ (declare (ignorable ,gensym))
+ (let (,@(when arg `((,arg ,gensym))))
+ ,@body)))))))
+ (let ((arglist (gensym "DECODED-ARGLIST+")))
+ (multiple-value-bind (initially-clauses main-clauses finally-clauses)
+ (parse-clauses clauses)
+ `(let ((,arglist ,decoded-arglist))
+ (block do-decoded-arglist
+ ,@(loop for keyword in '(&provided &required
+ &optional &rest &key &any)
+ append (cddr (gethash keyword initially-clauses))
+ collect (let ((clause (gethash keyword main-clauses)))
+ (when clause
+ (generate-main-clause clause arglist)))
+ append (cddr (gethash keyword finally-clauses)))))))))
+
+;;;; Arglist Printing
+
+(defun undummy (x)
+ (if (typep x 'arglist-dummy)
+ (arglist-dummy.string-representation x)
+ (prin1-to-string x)))
+
+(defun print-decoded-arglist (arglist &key operator provided-args highlight)
+ (let ((first-space-after-operator (and operator t)))
+ (macrolet ((space ()
+ ;; Kludge: When OPERATOR is not given, we don't want to
+ ;; print a space for the first argument.
+ `(if (not operator)
+ (setq operator t)
+ (progn (write-char #\space)
+ (if first-space-after-operator
+ (setq first-space-after-operator nil)
+ (pprint-newline :fill)))))
+ (with-highlighting ((&key index) &body body)
+ `(if (eql ,index (car highlight))
+ (progn (princ "===> ") ,@body (princ " <==="))
+ (progn ,@body)))
+ (print-arglist-recursively (argl &key index)
+ `(if (eql ,index (car highlight))
+ (print-decoded-arglist ,argl :highlight (cdr highlight))
+ (print-decoded-arglist ,argl))))
+ (let ((index 0))
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (when operator
+ (print-arg operator)
+ (pprint-indent :current 1)) ; 1 due to possibly added space
+ (do-decoded-arglist (remove-given-args arglist provided-args)
+ (&provided (arg)
+ (space)
+ (print-arg arg :literal-strings t)
+ (incf index))
+ (&required (arg)
+ (space)
+ (if (arglist-p arg)
+ (print-arglist-recursively arg :index index)
+ (with-highlighting (:index index)
+ (print-arg arg)))
+ (incf index))
+ (&optional :initially
+ (when (arglist.optional-args arglist)
+ (space)
+ (princ '&optional)))
+ (&optional (arg init-value)
+ (space)
+ (if (arglist-p arg)
+ (print-arglist-recursively arg :index index)
+ (with-highlighting (:index index)
+ (if (null init-value)
+ (print-arg arg)
+ (format t "~:@<~A ~A~@:>"
+ (undummy arg) (undummy init-value)))))
+ (incf index))
+ (&key :initially
+ (when (arglist.key-p arglist)
+ (space)
+ (princ '&key)))
+ (&key (keyword arg init)
+ (space)
+ (if (arglist-p arg)
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (prin1 keyword) (space)
+ (print-arglist-recursively arg :index keyword))
+ (with-highlighting (:index keyword)
+ (cond ((and init (keywordp keyword))
+ (format t "~:@<~A ~A~@:>" keyword (undummy init)))
+ (init
+ (format t "~:@<(~A ..) ~A~@:>"
+ (undummy keyword) (undummy init)))
+ ((not (keywordp keyword))
+ (format t "~:@<(~S ..)~@:>" keyword))
+ (t
+ (princ keyword))))))
+ (&key :finally
+ (when (arglist.allow-other-keys-p arglist)
+ (space)
+ (princ '&allow-other-keys)))
+ (&any :initially
+ (when (arglist.any-p arglist)
+ (space)
+ (princ '&any)))
+ (&any (arg)
+ (space)
+ (print-arg arg))
+ (&rest (args bodyp)
+ (space)
+ (princ (if bodyp '&body '&rest))
+ (space)
+ (if (arglist-p args)
+ (print-arglist-recursively args :index index)
+ (with-highlighting (:index index)
+ (print-arg args))))
+ ;; FIXME: add &UNKNOWN-JUNK?
+ ))))))
+
+(defun print-arg (arg &key literal-strings)
+ (let ((arg (if (arglist-dummy-p arg)
+ (arglist-dummy.string-representation arg)
+ arg)))
+ (if (or
+ (and literal-strings
+ (stringp arg))
+ (keywordp arg))
+ (prin1 arg)
+ (princ arg))))
+
+(defun print-decoded-arglist-as-template (decoded-arglist &key
+ (prefix "(") (suffix ")"))
+ (let ((first-p t))
+ (flet ((space ()
+ (unless first-p
+ (write-char #\space))
+ (setq first-p nil))
+ (print-arg-or-pattern (arg)
+ (etypecase arg
+ (symbol (if (keywordp arg) (prin1 arg) (princ arg)))
+ (string (princ arg))
+ (list (princ arg))
+ (arglist-dummy (princ
+ (arglist-dummy.string-representation arg)))
+ (arglist (print-decoded-arglist-as-template arg)))
+ (pprint-newline :fill)))
+ (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
+ (do-decoded-arglist decoded-arglist
+ (&provided ()) ; do nothing; provided args are in the buffer already.
+ (&required (arg)
+ (space) (print-arg-or-pattern arg))
+ (&optional (arg)
+ (space) (princ "[") (print-arg-or-pattern arg) (princ "]"))
+ (&key (keyword arg)
+ (space)
+ (prin1 (if (keywordp keyword) keyword `',keyword))
+ (space)
+ (print-arg-or-pattern arg)
+ (pprint-newline :linear))
+ (&any (arg)
+ (space) (print-arg-or-pattern arg))
+ (&rest (args)
+ (when (or (not (arglist.keyword-args decoded-arglist))
+ (arglist.allow-other-keys-p decoded-arglist))
+ (space)
+ (format t "~A..." args))))))))
+
+(defvar *arglist-pprint-bindings*
+ '((*print-case* . :downcase)
+ (*print-pretty* . t)
+ (*print-circle* . nil)
+ (*print-readably* . nil)
+ (*print-level* . 10)
+ (*print-length* . 20)
+ (*print-escape* . nil)))
+
+(defvar *arglist-show-packages* t)
+
+(defmacro with-arglist-io-syntax (&body body)
+ (let ((package (gensym)))
+ `(let ((,package *package*))
+ (with-standard-io-syntax
+ (let ((*package* (if *arglist-show-packages*
+ *package*
+ ,package)))
+ (with-bindings *arglist-pprint-bindings*
+ ,@body))))))
+
+(defun decoded-arglist-to-string (decoded-arglist
+ &key operator highlight
+ print-right-margin)
+ (with-output-to-string (*standard-output*)
+ (with-arglist-io-syntax
+ (let ((*print-right-margin* print-right-margin))
+ (print-decoded-arglist decoded-arglist
+ :operator operator
+ :highlight highlight)))))
+
+(defun decoded-arglist-to-template-string (decoded-arglist
+ &key (prefix "(") (suffix ")"))
+ (with-output-to-string (*standard-output*)
+ (with-arglist-io-syntax
+ (print-decoded-arglist-as-template decoded-arglist
+ :prefix prefix
+ :suffix suffix))))
+
+;;;; Arglist Decoding / Encoding
+
+(defun decode-required-arg (arg)
+ "ARG can be a symbol or a destructuring pattern."
+ (etypecase arg
+ (symbol arg)
+ (arglist-dummy arg)
+ (list (decode-arglist arg))))
+
+(defun encode-required-arg (arg)
+ (etypecase arg
+ (symbol arg)
+ (arglist (encode-arglist arg))))
+
+(defstruct (keyword-arg
+ (:conc-name keyword-arg.)
+ (:constructor %make-keyword-arg))
+ keyword
+ arg-name
+ default-arg)
+
+(defun canonicalize-default-arg (form)
+ (if (equalp ''nil form)
+ nil
+ form))
+
+(defun make-keyword-arg (keyword arg-name default-arg)
+ (%make-keyword-arg :keyword keyword
+ :arg-name arg-name
+ :default-arg (canonicalize-default-arg default-arg)))
+
+(defun decode-keyword-arg (arg)
+ "Decode a keyword item of formal argument list.
+Return three values: keyword, argument name, default arg."
+ (flet ((intern-as-keyword (arg)
+ (intern (etypecase arg
+ (symbol (symbol-name arg))
+ (arglist-dummy (arglist-dummy.string-representation arg)))
+ keyword-package)))
+ (cond ((or (symbolp arg) (arglist-dummy-p arg))
+ (make-keyword-arg (intern-as-keyword arg) arg nil))
+ ((and (consp arg)
+ (consp (car arg)))
+ (make-keyword-arg (caar arg)
+ (decode-required-arg (cadar arg))
+ (cadr arg)))
+ ((consp arg)
+ (make-keyword-arg (intern-as-keyword (car arg))
+ (car arg) (cadr arg)))
+ (t
+ (error "Bad keyword item of formal argument list")))))
+
+(defun encode-keyword-arg (arg)
+ (cond
+ ((arglist-p (keyword-arg.arg-name arg))
+ ;; Destructuring pattern
+ (let ((keyword/name (list (keyword-arg.keyword arg)
+ (encode-required-arg
+ (keyword-arg.arg-name arg)))))
+ (if (keyword-arg.default-arg arg)
+ (list keyword/name
+ (keyword-arg.default-arg arg))
+ (list keyword/name))))
+ ((eql (intern (symbol-name (keyword-arg.arg-name arg))
+ keyword-package)
+ (keyword-arg.keyword arg))
+ (if (keyword-arg.default-arg arg)
+ (list (keyword-arg.arg-name arg)
+ (keyword-arg.default-arg arg))
+ (keyword-arg.arg-name arg)))
+ (t
+ (let ((keyword/name (list (keyword-arg.keyword arg)
+ (keyword-arg.arg-name arg))))
+ (if (keyword-arg.default-arg arg)
+ (list keyword/name
+ (keyword-arg.default-arg arg))
+ (list keyword/name))))))
+
+(progn
+ (assert (equalp (decode-keyword-arg 'x)
+ (make-keyword-arg :x 'x nil)))
+ (assert (equalp (decode-keyword-arg '(x t))
+ (make-keyword-arg :x 'x t)))
+ (assert (equalp (decode-keyword-arg '((:x y)))
+ (make-keyword-arg :x 'y nil)))
+ (assert (equalp (decode-keyword-arg '((:x y) t))
+ (make-keyword-arg :x 'y t))))
+
+;;; FIXME suppliedp?
+(defstruct (optional-arg
+ (:conc-name optional-arg.)
+ (:constructor %make-optional-arg))
+ arg-name
+ default-arg)
+
+(defun make-optional-arg (arg-name default-arg)
+ (%make-optional-arg :arg-name arg-name
+ :default-arg (canonicalize-default-arg default-arg)))
+
+(defun decode-optional-arg (arg)
+ "Decode an optional item of a formal argument list.
+Return an OPTIONAL-ARG structure."
+ (etypecase arg
+ (symbol (make-optional-arg arg nil))
+ (arglist-dummy (make-optional-arg arg nil))
+ (list (make-optional-arg (decode-required-arg (car arg))
+ (cadr arg)))))
+
+(defun encode-optional-arg (optional-arg)
+ (if (or (optional-arg.default-arg optional-arg)
+ (arglist-p (optional-arg.arg-name optional-arg)))
+ (list (encode-required-arg
+ (optional-arg.arg-name optional-arg))
+ (optional-arg.default-arg optional-arg))
+ (optional-arg.arg-name optional-arg)))
+
+(progn
+ (assert (equalp (decode-optional-arg 'x)
+ (make-optional-arg 'x nil)))
+ (assert (equalp (decode-optional-arg '(x t))
+ (make-optional-arg 'x t))))
+
+(define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
+
+(defun decode-arglist (arglist)
+ "Parse the list ARGLIST and return an ARGLIST structure."
+ (etypecase arglist
+ ((eql :not-available) (return-from decode-arglist
+ :not-available))
+ (list))
+ (loop
+ with mode = nil
+ with result = (make-arglist)
+ for arg = (if (consp arglist)
+ (pop arglist)
+ (progn
+ (prog1 arglist
+ (setf mode '&rest
+ arglist nil))))
+ do (cond
+ ((eql mode '&unknown-junk)
+ ;; don't leave this mode -- we don't know how the arglist
+ ;; after unknown lambda-list keywords is interpreted
+ (push arg (arglist.unknown-junk result)))
+ ((eql arg '&allow-other-keys)
+ (setf (arglist.allow-other-keys-p result) t))
+ ((eql arg '&key)
+ (setf (arglist.key-p result) t
+ mode arg))
+ ((memq arg '(&optional &rest &body &aux))
+ (setq mode arg))
+ ((memq arg '(&whole &environment))
+ (setq mode arg)
+ (push arg (arglist.known-junk result)))
+ ((and (symbolp arg)
+ (string= (symbol-name arg) (string '#:&any))) ; may be interned
+ (setf (arglist.any-p result) t) ; in any *package*.
+ (setq mode '&any))
+ ((memq arg lambda-list-keywords)
+ (setq mode '&unknown-junk)
+ (push arg (arglist.unknown-junk result)))
+ (t
+ (ecase mode
+ (&key
+ (push (decode-keyword-arg arg)
+ (arglist.keyword-args result)))
+ (&optional
+ (push (decode-optional-arg arg)
+ (arglist.optional-args result)))
+ (&body
+ (setf (arglist.body-p result) t
+ (arglist.rest result) arg))
+ (&rest
+ (setf (arglist.rest result) arg))
+ (&aux
+ (push (decode-optional-arg arg)
+ (arglist.aux-args result)))
+ ((nil)
+ (push (decode-required-arg arg)
+ (arglist.required-args result)))
+ ((&whole &environment)
+ (setf mode nil)
+ (push arg (arglist.known-junk result)))
+ (&any
+ (push arg (arglist.any-args result))))))
+ until (null arglist)
+ finally (nreversef (arglist.required-args result))
+ finally (nreversef (arglist.optional-args result))
+ finally (nreversef (arglist.keyword-args result))
+ finally (nreversef (arglist.aux-args result))
+ finally (nreversef (arglist.any-args result))
+ finally (nreversef (arglist.known-junk result))
+ finally (nreversef (arglist.unknown-junk result))
+ finally (assert (or (and (not (arglist.key-p result))
+ (not (arglist.any-p result)))
+ (exactly-one-p (arglist.key-p result)
+ (arglist.any-p result))))
+ finally (return result)))
+
+(defun encode-arglist (decoded-arglist)
+ (append (mapcar #'encode-required-arg
+ (arglist.required-args decoded-arglist))
+ (when (arglist.optional-args decoded-arglist)
+ '(&optional))
+ (mapcar #'encode-optional-arg
+ (arglist.optional-args decoded-arglist))
+ (when (arglist.key-p decoded-arglist)
+ '(&key))
+ (mapcar #'encode-keyword-arg
+ (arglist.keyword-args decoded-arglist))
+ (when (arglist.allow-other-keys-p decoded-arglist)
+ '(&allow-other-keys))
+ (when (arglist.any-args decoded-arglist)
+ `(&any ,@(arglist.any-args decoded-arglist)))
+ (cond ((not (arglist.rest decoded-arglist))
+ '())
+ ((arglist.body-p decoded-arglist)
+ `(&body ,(arglist.rest decoded-arglist)))
+ (t
+ `(&rest ,(arglist.rest decoded-arglist))))
+ (when (arglist.aux-args decoded-arglist)
+ `(&aux ,(arglist.aux-args decoded-arglist)))
+ (arglist.known-junk decoded-arglist)
+ (arglist.unknown-junk decoded-arglist)))
+
+;;;; Arglist Enrichment
+
+(defun arglist-keywords (lambda-list)
+ "Return the list of keywords in ARGLIST.
+As a secondary value, return whether &allow-other-keys appears."
+ (let ((decoded-arglist (decode-arglist lambda-list)))
+ (values (arglist.keyword-args decoded-arglist)
+ (arglist.allow-other-keys-p decoded-arglist))))
+
+
+(defun methods-keywords (methods)
+ "Collect all keywords in the arglists of METHODS.
+As a secondary value, return whether &allow-other-keys appears somewhere."
+ (let ((keywords '())
+ (allow-other-keys nil))
+ (dolist (method methods)
+ (multiple-value-bind (kw aok)
+ (arglist-keywords
+ (swank-mop:method-lambda-list method))
+ (setq keywords (remove-duplicates (append keywords kw)
+ :key #'keyword-arg.keyword)
+ allow-other-keys (or allow-other-keys aok))))
+ (values keywords allow-other-keys)))
+
+(defun generic-function-keywords (generic-function)
+ "Collect all keywords in the methods of GENERIC-FUNCTION.
+As a secondary value, return whether &allow-other-keys appears somewhere."
+ (methods-keywords
+ (swank-mop:generic-function-methods generic-function)))
+
+(defun applicable-methods-keywords (generic-function arguments)
+ "Collect all keywords in the methods of GENERIC-FUNCTION that are
+applicable for argument of CLASSES. As a secondary value, return
+whether &allow-other-keys appears somewhere."
+ (methods-keywords
+ (multiple-value-bind (amuc okp)
+ (swank-mop:compute-applicable-methods-using-classes
+ generic-function (mapcar #'class-of arguments))
+ (if okp
+ amuc
+ (compute-applicable-methods generic-function arguments)))))
+
+(defgeneric extra-keywords (operator &rest args)
+ (:documentation "Return a list of extra keywords of OPERATOR (a
+symbol) when applied to the (unevaluated) ARGS.
+As a secondary value, return whether other keys are allowed.
+As a tertiary value, return the initial sublist of ARGS that was needed
+to determine the extra keywords."))
+
+;;; We make sure that symbol-from-KEYWORD-using keywords come before
+;;; symbol-from-arbitrary-package-using keywords. And we sort the
+;;; latter according to how their home-packages relate to *PACKAGE*.
+;;;
+;;; Rationale is to show those key parameters first which make most
+;;; sense in the current context. And in particular: to put
+;;; implementation-internal stuff last.
+;;;
+;;; This matters tremendeously on Allegro in combination with
+;;; AllegroCache as that does some evil tinkering with initargs,
+;;; obfuscating the arglist of MAKE-INSTANCE.
+;;;
+
+(defmethod extra-keywords :around (op &rest args)
+ (declare (ignorable op args))
+ (multiple-value-bind (keywords aok enrichments) (call-next-method)
+ (values (sort-extra-keywords keywords) aok enrichments)))
+
+(defun make-package-comparator (reference-packages)
+ "Returns a two-argument test function which compares packages
+according to their used-by relation with REFERENCE-PACKAGES. Packages
+will be sorted first which appear first in the PACKAGE-USE-LIST of the
+reference packages."
+ (let ((package-use-table (make-hash-table :test 'eq)))
+ ;; Walk the package dependency graph breadth-fist, and fill
+ ;; PACKAGE-USE-TABLE accordingly.
+ (loop with queue = (copy-list reference-packages)
+ with bfn = 0 ; Breadth-First Number
+ for p = (pop queue)
+ unless (gethash p package-use-table)
+ do (setf (gethash p package-use-table) (shiftf bfn (1+ bfn)))
+ and do (setf queue (nconc queue (copy-list (package-use-list p))))
+ while queue)
+ #'(lambda (p1 p2)
+ (let ((bfn1 (gethash p1 package-use-table))
+ (bfn2 (gethash p2 package-use-table)))
+ (cond ((and bfn1 bfn2) (<= bfn1 bfn2))
+ (bfn1 bfn1)
+ (bfn2 nil) ; p2 is used, p1 not
+ (t (string<= (package-name p1) (package-name p2))))))))
+
+(defun sort-extra-keywords (kwds)
+ (stable-sort kwds (make-package-comparator (list keyword-package *package*))
+ :key (compose #'symbol-package #'keyword-arg.keyword)))
+
+(defun keywords-of-operator (operator)
+ "Return a list of KEYWORD-ARGs that OPERATOR accepts.
+This function is useful for writing EXTRA-KEYWORDS methods for
+user-defined functions which are declared &ALLOW-OTHER-KEYS and which
+forward keywords to OPERATOR."
+ (with-available-arglist (arglist) (arglist-from-form (ensure-list operator))
+ (values (arglist.keyword-args arglist)
+ (arglist.allow-other-keys-p arglist))))
+
+(defmethod extra-keywords (operator &rest args)
+ ;; default method
+ (declare (ignore args))
+ (let ((symbol-function (symbol-function operator)))
+ (if (typep symbol-function 'generic-function)
+ (generic-function-keywords symbol-function)
+ nil)))
+
+(defun class-from-class-name-form (class-name-form)
+ (when (and (listp class-name-form)
+ (= (length class-name-form) 2)
+ (eq (car class-name-form) 'quote))
+ (let* ((class-name (cadr class-name-form))
+ (class (find-class class-name nil)))
+ (when (and class
+ (not (swank-mop:class-finalized-p class)))
+ ;; Try to finalize the class, which can fail if
+ ;; superclasses are not defined yet
+ (ignore-errors (swank-mop:finalize-inheritance class)))
+ class)))
+
+(defun extra-keywords/slots (class)
+ (multiple-value-bind (slots allow-other-keys-p)
+ (if (swank-mop:class-finalized-p class)
+ (values (swank-mop:class-slots class) nil)
+ (values (swank-mop:class-direct-slots class) t))
+ (let ((slot-init-keywords
+ (loop for slot in slots append
+ (mapcar (lambda (initarg)
+ (make-keyword-arg
+ initarg
+ (swank-mop:slot-definition-name slot)
+ (and (swank-mop:slot-definition-initfunction slot)
+ (swank-mop:slot-definition-initform slot))))
+ (swank-mop:slot-definition-initargs slot)))))
+ (values slot-init-keywords allow-other-keys-p))))
+
+(defun extra-keywords/make-instance (operator &rest args)
+ (declare (ignore operator))
+ (unless (null args)
+ (let* ((class-name-form (car args))
+ (class (class-from-class-name-form class-name-form)))
+ (when class
+ (multiple-value-bind (slot-init-keywords class-aokp)
+ (extra-keywords/slots class)
+ (multiple-value-bind (allocate-instance-keywords ai-aokp)
+ (applicable-methods-keywords
+ #'allocate-instance (list class))
+ (multiple-value-bind (initialize-instance-keywords ii-aokp)
+ (ignore-errors
+ (applicable-methods-keywords
+ #'initialize-instance
+ (list (swank-mop:class-prototype class))))
+ (multiple-value-bind (shared-initialize-keywords si-aokp)
+ (ignore-errors
+ (applicable-methods-keywords
+ #'shared-initialize
+ (list (swank-mop:class-prototype class) t)))
+ (values (append slot-init-keywords
+ allocate-instance-keywords
+ initialize-instance-keywords
+ shared-initialize-keywords)
+ (or class-aokp ai-aokp ii-aokp si-aokp)
+ (list class-name-form))))))))))
+
+(defun extra-keywords/change-class (operator &rest args)
+ (declare (ignore operator))
+ (unless (null args)
+ (let* ((class-name-form (car args))
+ (class (class-from-class-name-form class-name-form)))
+ (when class
+ (multiple-value-bind (slot-init-keywords class-aokp)
+ (extra-keywords/slots class)
+ (declare (ignore class-aokp))
+ (multiple-value-bind (shared-initialize-keywords si-aokp)
+ (ignore-errors
+ (applicable-methods-keywords
+ #'shared-initialize
+ (list (swank-mop:class-prototype class) t)))
+ ;; FIXME: much as it would be nice to include the
+ ;; applicable keywords from
+ ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see
+ ;; how to do it: so we punt, always declaring
+ ;; &ALLOW-OTHER-KEYS.
+ (declare (ignore si-aokp))
+ (values (append slot-init-keywords shared-initialize-keywords)
+ t
+ (list class-name-form))))))))
+
+(defmethod extra-keywords ((operator (eql 'make-instance))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'make-condition))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'error))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'signal))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'warn))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'cerror))
+ &rest args)
+ (multiple-value-bind (keywords aok determiners)
+ (apply #'extra-keywords/make-instance operator
+ (cdr args))
+ (if keywords
+ (values keywords aok
+ (cons (car args) determiners))
+ (call-next-method))))
+
+(defmethod extra-keywords ((operator (eql 'change-class))
+ &rest args)
+ (multiple-value-bind (keywords aok determiners)
+ (apply #'extra-keywords/change-class operator (cdr args))
+ (if keywords
+ (values keywords aok
+ (cons (car args) determiners))
+ (call-next-method))))
+
+(defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords
+ allow-other-keys-p)
+ "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
+ (when keywords
+ (setf (arglist.key-p decoded-arglist) t)
+ (setf (arglist.keyword-args decoded-arglist)
+ (remove-duplicates
+ (append (arglist.keyword-args decoded-arglist)
+ keywords)
+ :key #'keyword-arg.keyword)))
+ (setf (arglist.allow-other-keys-p decoded-arglist)
+ (or (arglist.allow-other-keys-p decoded-arglist)
+ allow-other-keys-p)))
+
+(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
+ "Determine extra keywords from the function call FORM, and modify
+DECODED-ARGLIST to include them. As a secondary return value, return
+the initial sublist of ARGS that was needed to determine the extra
+keywords. As a tertiary return value, return whether any enrichment
+was done."
+ (multiple-value-bind (extra-keywords extra-aok determining-args)
+ (apply #'extra-keywords form)
+ ;; enrich the list of keywords with the extra keywords
+ (enrich-decoded-arglist-with-keywords decoded-arglist
+ extra-keywords extra-aok)
+ (values decoded-arglist
+ determining-args
+ (or extra-keywords extra-aok))))
+
+(defgeneric compute-enriched-decoded-arglist (operator-form argument-forms)
+ (:documentation
+ "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and
+ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords.
+If the arglist is not available, return :NOT-AVAILABLE."))
+
+(defmethod compute-enriched-decoded-arglist (operator-form argument-forms)
+ (with-available-arglist (decoded-arglist)
+ (decode-arglist (arglist operator-form))
+ (enrich-decoded-arglist-with-extra-keywords decoded-arglist
+ (cons operator-form
+ argument-forms))))
+
+(defmethod compute-enriched-decoded-arglist
+ ((operator-form (eql 'with-open-file)) argument-forms)
+ (declare (ignore argument-forms))
+ (multiple-value-bind (decoded-arglist determining-args)
+ (call-next-method)
+ (let ((first-arg (first (arglist.required-args decoded-arglist)))
+ (open-arglist (compute-enriched-decoded-arglist 'open nil)))
+ (when (and (arglist-p first-arg) (arglist-p open-arglist))
+ (enrich-decoded-arglist-with-keywords
+ first-arg
+ (arglist.keyword-args open-arglist)
+ nil)))
+ (values decoded-arglist determining-args t)))
+
+(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply))
+ argument-forms)
+ (let ((function-name-form (car argument-forms)))
+ (when (and (listp function-name-form)
+ (length= function-name-form 2)
+ (memq (car function-name-form) '(quote function)))
+ (let ((function-name (cadr function-name-form)))
+ (when (valid-operator-symbol-p function-name)
+ (let ((function-arglist
+ (compute-enriched-decoded-arglist function-name
+ (cdr argument-forms))))
+ (return-from compute-enriched-decoded-arglist
+ (values
+ (make-arglist :required-args
+ (list 'function)
+ :optional-args
+ (append
+ (mapcar #'(lambda (arg)
+ (make-optional-arg arg nil))
+ (arglist.required-args function-arglist))
+ (arglist.optional-args function-arglist))
+ :key-p
+ (arglist.key-p function-arglist)
+ :keyword-args
+ (arglist.keyword-args function-arglist)
+ :rest
+ 'args
+ :allow-other-keys-p
+ (arglist.allow-other-keys-p function-arglist))
+ (list function-name-form)
+ t)))))))
+ (call-next-method))
+
+(defmethod compute-enriched-decoded-arglist
+ ((operator-form (eql 'multiple-value-call)) argument-forms)
+ (compute-enriched-decoded-arglist 'apply argument-forms))
+
+(defun delete-given-args (decoded-arglist args)
+ "Delete given ARGS from DECODED-ARGLIST."
+ (macrolet ((pop-or-return (list)
+ `(if (null ,list)
+ (return-from do-decoded-arglist)
+ (pop ,list))))
+ (do-decoded-arglist decoded-arglist
+ (&provided ()
+ (assert (eq (pop-or-return args)
+ (pop (arglist.provided-args decoded-arglist)))))
+ (&required ()
+ (pop-or-return args)
+ (pop (arglist.required-args decoded-arglist)))
+ (&optional ()
+ (pop-or-return args)
+ (pop (arglist.optional-args decoded-arglist)))
+ (&key (keyword)
+ ;; N.b. we consider a keyword to be given only when the keyword
+ ;; _and_ a value has been given for it.
+ (loop for (key value) on args by #'cddr
+ when (and (eq keyword key) value)
+ do (setf (arglist.keyword-args decoded-arglist)
+ (remove keyword (arglist.keyword-args decoded-arglist)
+ :key #'keyword-arg.keyword))))))
+ decoded-arglist)
+
+(defun remove-given-args (decoded-arglist args)
+ ;; FIXME: We actually needa deep copy here.
+ (delete-given-args (copy-arglist decoded-arglist) args))
+
+;;;; Arglist Retrieval
+
+(defun arglist-from-form (form)
+ (if (null form)
+ :not-available
+ (arglist-dispatch (car form) (cdr form))))
+
+(export 'arglist-dispatch)
+(defgeneric arglist-dispatch (operator arguments)
+ ;; Default method
+ (:method (operator arguments)
+ (unless (and (symbolp operator) (valid-operator-symbol-p operator))
+ (return-from arglist-dispatch :not-available))
+
+ (multiple-value-bind (decoded-arglist determining-args)
+ (compute-enriched-decoded-arglist operator arguments)
+ (with-available-arglist (arglist) decoded-arglist
+ ;; replace some formal args by determining actual args
+ (setf arglist (delete-given-args arglist determining-args))
+ (setf (arglist.provided-args arglist) determining-args)
+ arglist))))
+
+(defmethod arglist-dispatch ((operator (eql 'defmethod)) arguments)
+ (match (cons operator arguments)
+ (('defmethod (#'function-exists-p gf-name) . rest)
+ (let ((gf (fdefinition gf-name)))
+ (when (typep gf 'generic-function)
+ (with-available-arglist (arglist) (decode-arglist (arglist gf))
+ (let ((qualifiers (loop for x in rest
+ until (or (listp x) (empty-arg-p x))
+ collect x)))
+ (return-from arglist-dispatch
+ (make-arglist :provided-args (cons gf-name qualifiers)
+ :required-args (list arglist)
+ :rest "body" :body-p t)))))))
+ (_)) ; Fall through
+ (call-next-method))
+
+(defmethod arglist-dispatch ((operator (eql 'define-compiler-macro)) arguments)
+ (match (cons operator arguments)
+ (('define-compiler-macro (#'function-exists-p gf-name) . _)
+ (let ((gf (fdefinition gf-name)))
+ (with-available-arglist (arglist) (decode-arglist (arglist gf))
+ (return-from arglist-dispatch
+ (make-arglist :provided-args (list gf-name)
+ :required-args (list arglist)
+ :rest "body" :body-p t)))))
+ (_)) ; Fall through
+ (call-next-method))
+
+
+(defmethod arglist-dispatch ((operator (eql 'eval-when)) arguments)
+ (declare (ignore arguments))
+ (let ((eval-when-args '(:compile-toplevel :load-toplevel :execute)))
+ (make-arglist
+ :required-args (list (make-arglist :any-p t :any-args eval-when-args))
+ :rest '#:body :body-p t)))
+
+
+(defmethod arglist-dispatch ((operator (eql 'declare)) arguments)
+ (let* ((declaration (cons operator (last arguments)))
+ (typedecl-arglist (arglist-for-type-declaration declaration)))
+ (if (arglist-available-p typedecl-arglist)
+ typedecl-arglist
+ (match declaration
+ (('declare ((#'consp typespec) . decl-args))
+ (with-available-arglist (typespec-arglist)
+ (decoded-arglist-for-type-specifier typespec)
+ (make-arglist
+ :required-args (list (make-arglist
+ :required-args (list typespec-arglist)
+ :rest '#:variables)))))
+ (('declare (decl-identifier . decl-args))
+ (decoded-arglist-for-declaration decl-identifier decl-args))
+ (_ (make-arglist :rest '#:declaration-specifiers))))))
+
+(defmethod arglist-dispatch ((operator (eql 'declaim)) arguments)
+ (arglist-dispatch 'declare arguments))
+
+
+(defun arglist-for-type-declaration (declaration)
+ (flet ((%arglist-for-type-declaration (identifier typespec rest-var-name)
+ (with-available-arglist (typespec-arglist)
+ (decoded-arglist-for-type-specifier typespec)
+ (make-arglist
+ :required-args (list (make-arglist
+ :provided-args (list identifier)
+ :required-args (list typespec-arglist)
+ :rest rest-var-name))))))
+ (match declaration
+ (('declare ('type (#'consp typespec) . decl-args))
+ (%arglist-for-type-declaration 'type typespec '#:variables))
+ (('declare ('ftype (#'consp typespec) . decl-args))
+ (%arglist-for-type-declaration 'ftype typespec '#:function-names))
+ (('declare ((#'consp typespec) . decl-args))
+ (with-available-arglist (typespec-arglist)
+ (decoded-arglist-for-type-specifier typespec)
+ (make-arglist
+ :required-args (list (make-arglist
+ :required-args (list typespec-arglist)
+ :rest '#:variables)))))
+ (_ :not-available))))
+
+(defun decoded-arglist-for-declaration (decl-identifier decl-args)
+ (declare (ignore decl-args))
+ (with-available-arglist (arglist)
+ (decode-arglist (declaration-arglist decl-identifier))
+ (setf (arglist.provided-args arglist) (list decl-identifier))
+ (make-arglist :required-args (list arglist))))
+
+(defun decoded-arglist-for-type-specifier (type-specifier)
+ (etypecase type-specifier
+ (arglist-dummy :not-available)
+ (cons (decoded-arglist-for-type-specifier (car type-specifier)))
+ (symbol
+ (with-available-arglist (arglist)
+ (decode-arglist (type-specifier-arglist type-specifier))
+ (setf (arglist.provided-args arglist) (list type-specifier))
+ arglist))))
+
+;;; Slimefuns
+
+;;; We work on a RAW-FORM, or BUFFER-FORM, which represent the form at
+;;; user's point in Emacs. A RAW-FORM looks like
+;;;
+;;; ("FOO" ("BAR" ...) "QUUX" ("ZURP" SWANK::%CURSOR-MARKER%))
+;;;
+;;; The expression before the cursor marker is the expression where
+;;; user's cursor points at. An explicit marker is necessary to
+;;; disambiguate between
+;;;
+;;; ("IF" ("PRED")
+;;; ("F" "X" "Y" %CURSOR-MARKER%))
+;;;
+;;; and
+;;; ("IF" ("PRED")
+;;; ("F" "X" "Y") %CURSOR-MARKER%)
+
+;;; Notice that for a form like (FOO (BAR |) QUUX), where | denotes
+;;; user's point, the following should be sent ("FOO" ("BAR" ""
+;;; %CURSOR-MARKER%)). Only the forms up to point should be
+;;; considered.
+
+(defslimefun autodoc (raw-form &key print-right-margin)
+ "Return a list of two elements.
+First, a string representing the arglist for the deepest subform in
+RAW-FORM that does have an arglist. The highlighted parameter is
+wrapped in ===> X <===.
+
+Second, a boolean value telling whether the returned string can be cached."
+ (handler-bind ((serious-condition
+ #'(lambda (c)
+ (unless (debug-on-swank-error)
+ (let ((*print-right-margin* print-right-margin))
+ (return-from autodoc
+ (format nil "Arglist Error: \"~A\"" c)))))))
+ (with-buffer-syntax ()
+ (multiple-value-bind (form arglist obj-at-cursor form-path)
+ (find-subform-with-arglist (parse-raw-form raw-form))
+ (cond ((boundp-and-interesting obj-at-cursor)
+ (list (print-variable-to-string obj-at-cursor) nil))
+ (t
+ (list
+ (with-available-arglist (arglist) arglist
+ (decoded-arglist-to-string
+ arglist
+ :print-right-margin print-right-margin
+ :operator (car form)
+ :highlight (form-path-to-arglist-path form-path
+ form
+ arglist)))
+ t)))))))
+
+(defun boundp-and-interesting (symbol)
+ (and symbol
+ (symbolp symbol)
+ (boundp symbol)
+ (not (memq symbol '(cl:t cl:nil)))
+ (not (keywordp symbol))))
+
+(defun print-variable-to-string (symbol)
+ "Return a short description of VARIABLE-NAME, or NIL."
+ (let ((*print-pretty* t) (*print-level* 4)
+ (*print-length* 10) (*print-lines* 1)
+ (*print-readably* nil)
+ (value (symbol-value symbol)))
+ (call/truncated-output-to-string
+ 75 (lambda (s)
+ (without-printing-errors (:object value :stream s)
+ (format s "~A ~A~S" symbol *echo-area-prefix* value))))))
+
+
+(defslimefun complete-form (raw-form)
+ "Read FORM-STRING in the current buffer package, then complete it
+ by adding a template for the missing arguments."
+ ;; We do not catch errors here because COMPLETE-FORM is an
+ ;; interactive command, not automatically run in the background like
+ ;; ARGLIST-FOR-ECHO-AREA.
+ (with-buffer-syntax ()
+ (multiple-value-bind (arglist provided-args)
+ (find-immediately-containing-arglist (parse-raw-form raw-form))
+ (with-available-arglist (arglist) arglist
+ (decoded-arglist-to-template-string
+ (delete-given-args arglist
+ (remove-if #'empty-arg-p provided-args
+ :from-end t :count 1))
+ :prefix "" :suffix "")))))
+
+(defslimefun completions-for-keyword (keyword-string raw-form)
+ "Return a list of possible completions for KEYWORD-STRING relative
+to the context provided by RAW-FORM."
+ (with-buffer-syntax ()
+ (let ((arglist (find-immediately-containing-arglist
+ (parse-raw-form raw-form))))
+ (when (arglist-available-p arglist)
+ ;; It would be possible to complete keywords only if we are in
+ ;; a keyword position, but it is not clear if we want that.
+ (let* ((keywords
+ (append (mapcar #'keyword-arg.keyword
+ (arglist.keyword-args arglist))
+ (remove-if-not #'keywordp (arglist.any-args arglist))))
+ (keyword-name
+ (tokenize-symbol keyword-string))
+ (matching-keywords
+ (find-matching-symbols-in-list
+ keyword-name keywords (make-compound-prefix-matcher #\-)))
+ (converter (completion-output-symbol-converter keyword-string))
+ (strings
+ (mapcar converter
+ (mapcar #'symbol-name matching-keywords)))
+ (completion-set
+ (format-completion-set strings nil "")))
+ (list completion-set
+ (longest-compound-prefix completion-set)))))))
+
+(defparameter +cursor-marker+ '%cursor-marker%)
+
+(defun find-subform-with-arglist (form)
+ "Returns four values:
+
+ The appropriate subform of `form' which is closest to the
+ +CURSOR-MARKER+ and whose operator is valid and has an
+ arglist. The +CURSOR-MARKER+ is removed from that subform.
+
+ Second value is the arglist. Local function and macro definitions
+ appearing in `form' into account.
+
+ Third value is the object in front of +CURSOR-MARKER+.
+
+ Fourth value is a form path to that object."
+ (labels
+ ((yield-success (form local-ops)
+ (multiple-value-bind (form obj-at-cursor form-path)
+ (extract-cursor-marker form)
+ (values form
+ (let ((entry (assoc (car form) local-ops :test #'op=)))
+ (if entry
+ (decode-arglist (cdr entry))
+ (arglist-from-form form)))
+ obj-at-cursor
+ form-path)))
+ (yield-failure ()
+ (values nil :not-available))
+ (operator-p (operator local-ops)
+ (or (and (symbolp operator) (valid-operator-symbol-p operator))
+ (assoc operator local-ops :test #'op=)))
+ (op= (op1 op2)
+ (cond ((and (symbolp op1) (symbolp op2))
+ (eq op1 op2))
+ ((and (arglist-dummy-p op1) (arglist-dummy-p op2))
+ (string= (arglist-dummy.string-representation op1)
+ (arglist-dummy.string-representation op2)))))
+ (grovel-form (form local-ops)
+ "Descend FORM top-down, always taking the rightest branch,
+ until +CURSOR-MARKER+."
+ (assert (listp form))
+ (destructuring-bind (operator . args) form
+ ;; N.b. the user's cursor is at the rightmost, deepest
+ ;; subform right before +CURSOR-MARKER+.
+ (let ((last-subform (car (last form)))
+ (new-ops))
+ (cond
+ ((eq last-subform +cursor-marker+)
+ (if (operator-p operator local-ops)
+ (yield-success form local-ops)
+ (yield-failure)))
+ ((not (operator-p operator local-ops))
+ (grovel-form last-subform local-ops))
+ ;; Make sure to pick up the arglists of local
+ ;; function/macro definitions.
+ ((setq new-ops (extract-local-op-arglists operator args))
+ (multiple-value-or (grovel-form last-subform
+ (nconc new-ops local-ops))
+ (yield-success form local-ops)))
+ ;; Some typespecs clash with function names, so we make
+ ;; sure to bail out early.
+ ((member operator '(cl:declare cl:declaim))
+ (yield-success form local-ops))
+ ;; Mostly uninteresting, hence skip.
+ ((memq operator '(cl:quote cl:function))
+ (yield-failure))
+ (t
+ (multiple-value-or (grovel-form last-subform local-ops)
+ (yield-success form local-ops))))))))
+ (if (null form)
+ (yield-failure)
+ (grovel-form form '()))))
+
+(defun extract-cursor-marker (form)
+ "Returns three values: normalized `form' without +CURSOR-MARKER+,
+the object in front of +CURSOR-MARKER+, and a form path to that
+object."
+ (labels ((grovel (form last path)
+ (let ((result-form))
+ (loop for (car . cdr) on form do
+ (cond ((eql car +cursor-marker+)
+ (decf (first path))
+ (return-from grovel
+ (values (nreconc result-form cdr)
+ last
+ (nreverse path))))
+ ((consp car)
+ (multiple-value-bind (new-car new-last new-path)
+ (grovel car last (cons 0 path))
+ (when new-path ; CAR contained cursor-marker?
+ (return-from grovel
+ (values (nreconc
+ (cons new-car result-form) cdr)
+ new-last
+ new-path))))))
+ (push car result-form)
+ (setq last car)
+ (incf (first path))
+ finally
+ (return-from grovel
+ (values (nreverse result-form) nil nil))))))
+ (grovel form nil (list 0))))
+
+(defgeneric extract-local-op-arglists (operator args)
+ (:documentation
+ "If the form `(OPERATOR ,@ARGS) is a local operator binding form,
+ return a list of pairs (OP . ARGLIST) for each locally bound op.")
+ (:method (operator args)
+ (declare (ignore operator args))
+ nil)
+ ;; FLET
+ (:method ((operator (eql 'cl:flet)) args)
+ (let ((defs (first args))
+ (body (rest args)))
+ (cond ((null body) nil) ; `(flet ((foo (x) |'
+ ((atom defs) nil) ; `(flet ,foo (|'
+ (t (%collect-op/argl-alist defs)))))
+ ;; LABELS
+ (:method ((operator (eql 'cl:labels)) args)
+ ;; Notice that we only have information to "look backward" and
+ ;; show arglists of previously occuring local functions.
+ (destructuring-bind (defs . body) args
+ (unless (or (atom defs) (null body)) ; `(labels ,foo (|'
+ (let ((current-def (car (last defs))))
+ (cond ((atom current-def) nil) ; `(labels ((foo (x) ...)|'
+ ((not (null body))
+ (extract-local-op-arglists 'cl:flet args))
+ (t
+ (let ((def.body (cddr current-def)))
+ (when def.body
+ (%collect-op/argl-alist defs)))))))))
+ ;; MACROLET
+ (:method ((operator (eql 'cl:macrolet)) args)
+ (extract-local-op-arglists 'cl:labels args)))
+
+(defun %collect-op/argl-alist (defs)
+ (setq defs (remove-if-not #'(lambda (x)
+ ;; Well-formed FLET/LABELS def?
+ (and (consp x) (second x)))
+ defs))
+ (loop for (name arglist . nil) in defs
+ collect (cons name arglist)))
+
+(defun find-immediately-containing-arglist (form)
+ "Returns the arglist of the subform _immediately_ containing
++CURSOR-MARKER+ in `form'. Notice, however, that +CURSOR-MARKER+ may
+be in a nested arglist \(e.g. `(WITH-OPEN-FILE (<here>'\), and the
+arglist of the appropriate parent form \(WITH-OPEN-FILE\) will be
+returned in that case."
+ (flet ((try (form-path form arglist)
+ (let* ((arglist-path (form-path-to-arglist-path form-path
+ form
+ arglist))
+ (argl (apply #'arglist-ref
+ arglist
+ arglist-path))
+ (args (apply #'provided-arguments-ref
+ (cdr form)
+ arglist
+ arglist-path)))
+ (when (and (arglist-p argl) (listp args))
+ (values argl args)))))
+ (multiple-value-bind (form arglist obj form-path)
+ (find-subform-with-arglist form)
+ (declare (ignore obj))
+ (with-available-arglist (arglist) arglist
+ ;; First try the form the cursor is in (in case of a normal
+ ;; form), then try the surrounding form (in case of a nested
+ ;; macro form).
+ (multiple-value-or (try form-path form arglist)
+ (try (butlast form-path) form arglist)
+ :not-available)))))
+
+(defun form-path-to-arglist-path (form-path form arglist)
+ "Convert a form path to an arglist path consisting of arglist
+indices."
+ (labels ((convert (path args arglist)
+ (if (null path)
+ nil
+ (let* ((idx (car path))
+ (idx* (arglist-index idx args arglist))
+ (arglist* (and idx* (arglist-ref arglist idx*)))
+ (args* (and idx* (provided-arguments-ref args
+ arglist
+ idx*))))
+ ;; The FORM-PATH may be more detailed than ARGLIST;
+ ;; consider (defun foo (x y) ...), a form path may
+ ;; point into the function's lambda-list, but the
+ ;; arglist of DEFUN won't contain as much information.
+ ;; So we only recurse if possible.
+ (cond ((null idx*)
+ nil)
+ ((arglist-p arglist*)
+ (cons idx* (convert (cdr path) args* arglist*)))
+ (t
+ (list idx*)))))))
+ (convert
+ ;; FORM contains irrelevant operator. Adjust FORM-PATH.
+ (cond ((null form-path) nil)
+ ((equal form-path '(0)) nil)
+ (t
+ (destructuring-bind (car . cdr) form-path
+ (cons (1- car) cdr))))
+ (cdr form)
+ arglist)))
+
+(defun arglist-index (provided-argument-index provided-arguments arglist)
+ "Return the arglist index into `arglist' for the parameter belonging
+to the argument (NTH `provided-argument-index' `provided-arguments')."
+ (let ((positional-args# (positional-args-number arglist))
+ (arg-index provided-argument-index))
+ (with-struct (arglist. key-p rest) arglist
+ (cond
+ ((< arg-index positional-args#) ; required + optional
+ arg-index)
+ ((and (not key-p) (not rest)) ; more provided than allowed
+ nil)
+ ((not key-p) ; rest + body
+ (assert (arglist.rest arglist))
+ positional-args#)
+ (t ; key
+ ;; Find last provided &key parameter
+ (let* ((argument (nth arg-index provided-arguments))
+ (provided-keys (subseq provided-arguments positional-args#)))
+ (loop for (key value) on provided-keys by #'cddr
+ when (eq value argument)
+ return (match key
+ (('quote symbol) symbol)
+ (_ key)))))))))
+
+(defun arglist-ref (arglist &rest indices)
+ "Returns the parameter in ARGLIST along the INDICIES path. Numbers
+represent positional parameters (required, optional), keywords
+represent key parameters."
+ (flet ((ref-positional-arg (arglist index)
+ (check-type index (integer 0 *))
+ (with-struct (arglist. provided-args required-args
+ optional-args rest)
+ arglist
+ (loop for args in (list provided-args required-args
+ (mapcar #'optional-arg.arg-name
+ optional-args))
+ for args# = (length args)
+ if (< index args#)
+ return (nth index args)
+ else
+ do (decf index args#)
+ finally (return (or rest nil)))))
+ (ref-keyword-arg (arglist keyword)
+ ;; keyword argument may be any symbol,
+ ;; not only from the KEYWORD package.
+ (let ((keyword (match keyword
+ (('quote symbol) symbol)
+ (_ keyword))))
+ (do-decoded-arglist arglist
+ (&key (kw arg) (when (eq kw keyword)
+ (return-from ref-keyword-arg arg)))))
+ nil))
+ (dolist (index indices)
+ (assert (arglist-p arglist))
+ (setq arglist (if (numberp index)
+ (ref-positional-arg arglist index)
+ (ref-keyword-arg arglist index))))
+ arglist))
+
+(defun provided-arguments-ref (provided-args arglist &rest indices)
+ "Returns the argument in PROVIDED-ARGUMENT along the INDICES path
+relative to ARGLIST."
+ (check-type arglist arglist)
+ (flet ((ref (provided-args arglist index)
+ (if (numberp index)
+ (nth index provided-args)
+ (let ((provided-keys (subseq provided-args
+ (positional-args-number arglist))))
+ (loop for (key value) on provided-keys
+ when (eq key index)
+ return value)))))
+ (dolist (idx indices)
+ (setq provided-args (ref provided-args arglist idx))
+ (setq arglist (arglist-ref arglist idx)))
+ provided-args))
+
+(defun positional-args-number (arglist)
+ (+ (length (arglist.provided-args arglist))
+ (length (arglist.required-args arglist))
+ (length (arglist.optional-args arglist))))
+
+(defun parse-raw-form (raw-form)
+ "Parse a RAW-FORM into a Lisp form. I.e. substitute strings by
+symbols if already interned. For strings not already interned, use
+ARGLIST-DUMMY."
+ (unless (null raw-form)
+ (loop for element in raw-form
+ collect (etypecase element
+ (string (read-conversatively element))
+ (list (parse-raw-form element))
+ (symbol (prog1 element
+ ;; Comes after list, so ELEMENT can't be NIL.
+ (assert (eq element +cursor-marker+))))))))
+
+(defun read-conversatively (string)
+ "Tries to find the symbol that's represented by STRING.
+
+If it can't, this either means that STRING does not represent a
+symbol, or that the symbol behind STRING would have to be freshly
+interned. Because this function is supposed to be called from the
+automatic arglist display stuff from Slime, interning freshly
+symbols is a big no-no.
+
+In such a case (that no symbol could be found), an object of type
+ARGLIST-DUMMY is returned instead, which works as a placeholder
+datum for subsequent logics to rely on."
+ (let* ((string (string-left-trim '(#\Space #\Tab #\Newline) string))
+ (length (length string))
+ (type (cond ((zerop length) nil)
+ ((eql (aref string 0) #\')
+ :quoted-symbol)
+ ((search "#'" string :end2 (min length 2))
+ :sharpquoted-symbol)
+ ((char= (char string 0) (char string (1- length))
+ #\")
+ :string)
+ (t
+ :symbol))))
+ (multiple-value-bind (symbol found?)
+ (case type
+ (:symbol (parse-symbol string))
+ (:quoted-symbol (parse-symbol (subseq string 1)))
+ (:sharpquoted-symbol (parse-symbol (subseq string 2)))
+ (:string (values string t))
+ (t (values string nil)))
+ (if found?
+ (ecase type
+ (:symbol symbol)
+ (:quoted-symbol `(quote ,symbol))
+ (:sharpquoted-symbol `(function ,symbol))
+ (:string (if (> length 1)
+ (subseq string 1 (1- length))
+ string)))
+ (make-arglist-dummy string)))))
+
+(defun test-print-arglist ()
+ (flet ((test (arglist &rest strings)
+ (let* ((*package* (find-package :swank))
+ (actual (decoded-arglist-to-string
+ (decode-arglist arglist)
+ :print-right-margin 1000)))
+ (unless (loop for string in strings
+ thereis (string= actual string))
+ (warn "Test failed: ~S => ~S~% Expected: ~A"
+ arglist actual
+ (if (cdr strings)
+ (format nil "One of: ~{~S~^, ~}" strings)
+ (format nil "~S" (first strings))))))))
+ (test '(function cons) "(function cons)")
+ (test '(quote cons) "(quote cons)")
+ (test '(&key (function #'+))
+ "(&key (function #'+))" "(&key (function (function +)))")
+ (test '(&whole x y z) "(y z)")
+ (test '(x &aux y z) "(x)")
+ (test '(x &environment env y) "(x y)")
+ (test '(&key ((function f))) "(&key ((function ..)))")
+ (test
+ '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)
+ "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)")
+ (test '(declare (optimize &any (speed 1) (safety 1)))
+ "(declare (optimize &any (speed 1) (safety 1)))")))
+
+(defun test-arglist-ref ()
+ (macrolet ((soft-assert (form)
+ `(unless ,form
+ (warn "Assertion failed: ~S~%" ',form))))
+ (let ((sample (decode-arglist '(x &key ((:k (y z)))))))
+ (soft-assert (eq (arglist-ref sample 0) 'x))
+ (soft-assert (eq (arglist-ref sample :k 0) 'y))
+ (soft-assert (eq (arglist-ref sample :k 1) 'z))
+
+ (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample 0)
+ 'a))
+ (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 0)
+ 'b))
+ (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 1)
+ 'c)))))
+
+(test-print-arglist)
+(test-arglist-ref)
+
+(provide :swank-arglists)
diff --git a/vim/bundle/slimv/slime/contrib/swank-asdf.lisp b/vim/bundle/slimv/slime/contrib/swank-asdf.lisp
new file mode 100644
index 0000000..2bcedd0
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-asdf.lisp
@@ -0,0 +1,536 @@
+;;; swank-asdf.lisp -- ASDF support
+;;
+;; Authors: Daniel Barlow <dan@telent.net>
+;; Marco Baringer <mb@bese.it>
+;; Edi Weitz <edi@agharta.de>
+;; Francois-Rene Rideau <tunes@google.com>
+;; and others
+;; License: Public Domain
+;;
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+;;; The best way to load ASDF is from an init file of an
+;;; implementation. If ASDF is not loaded at the time swank-asdf is
+;;; loaded, it will be tried first with (require "asdf"), if that
+;;; doesn't help and *asdf-path* is set, it will be loaded from that
+;;; file.
+;;; To set *asdf-path* put the following into ~/.swank.lisp:
+;;; (defparameter swank::*asdf-path* #p"/path/to/asdf/asdf.lisp")
+ (defvar *asdf-path* nil
+ "Path to asdf.lisp file, to be loaded in case (require \"asdf\") fails."))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (member :asdf *features*)
+ (ignore-errors (funcall 'require "asdf"))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (member :asdf *features*)
+ (handler-bind ((warning #'muffle-warning))
+ (when *asdf-path*
+ (load *asdf-path* :if-does-not-exist nil)))))
+
+;; If still not found, error out.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (member :asdf *features*)
+ (error "Could not load ASDF.
+Please update your implementation or
+install a recent release of ASDF and in your ~~/.swank.lisp specify:
+ (defparameter swank::*asdf-path* #p\"/path/containing/asdf/asdf.lisp\")")))
+
+;;; If ASDF is too old, punt.
+;; As of January 2014, Quicklisp has been providing 2.26 for a year
+;; (and previously had 2.014.6 for over a year), whereas
+;; all SLIME-supported implementations provide ASDF3 (i.e. 2.27 or later)
+;; except LispWorks (stuck with 2.019) and SCL (which hasn't been released
+;; in years and doesn't provide ASDF at all, but is fully supported by ASDF).
+;; If your implementation doesn't provide ASDF, or provides an old one,
+;; install an upgrade yourself and configure *asdf-path*.
+;; It's just not worth the hassle supporting something
+;; that doesn't even have COERCE-PATHNAME.
+;;
+;; NB: this version check is duplicated in swank-loader.lisp so that we don't
+;; try to load this contrib when ASDF is too old since that will abort the SLIME
+;; connection.
+#-asdf3
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (or #+asdf3 t #+asdf2
+ (asdf:version-satisfies (asdf:asdf-version) "2.14.6"))
+ (error "Your ASDF is too old. ~
+ The oldest version supported by swank-asdf is 2.014.6.")))
+;;; Import functionality from ASDF that isn't available in all ASDF versions.
+;;; Please do NOT depend on any of the below as reference:
+;;; they are sometimes stripped down versions, for compatibility only.
+;;; Indeed, they are supposed to work on *OLDER*, not *NEWER* versions of ASDF.
+;;;
+;;; The way I got these is usually by looking at the current definition,
+;;; using git blame in one screen to locate which commit last modified it,
+;;; and git log in another to determine which release that made it in.
+;;; It is OK for some of the below definitions to be or become obsolete,
+;;; as long as it will make do with versions older than the tagged version:
+;;; if ASDF is more recent, its more recent version will win.
+;;;
+;;; If your software is hacking ASDF, use its internals.
+;;; If you want ASDF utilities in user software, please use ASDF-UTILS.
+
+(defun asdf-at-least (version)
+ (asdf:version-satisfies (asdf:asdf-version) version))
+
+(defmacro asdefs (version &rest defs)
+ (flet ((defun* (version name aname rest)
+ `(progn
+ (defun ,name ,@rest)
+ (declaim (notinline ,name))
+ (when (asdf-at-least ,version)
+ (setf (fdefinition ',name) (fdefinition ',aname)))))
+ (defmethod* (version aname rest)
+ `(unless (asdf-at-least ,version)
+ (defmethod ,aname ,@rest)))
+ (defvar* (name aname rest)
+ `(progn
+ (define-symbol-macro ,name ,aname)
+ (defvar ,aname ,@rest))))
+ `(progn
+ ,@(loop :for (def name . args) :in defs
+ :for aname = (intern (string name) :asdf)
+ :collect
+ (ecase def
+ ((defun) (defun* version name aname args))
+ ((defmethod) (defmethod* version aname args))
+ ((defvar) (defvar* name aname args)))))))
+
+(asdefs "2.15"
+ (defvar *wild* #-cormanlisp :wild #+cormanlisp "*")
+
+ (defun collect-asds-in-directory (directory collect)
+ (map () collect (directory-asd-files directory)))
+
+ (defun register-asd-directory (directory &key recurse exclude collect)
+ (if (not recurse)
+ (collect-asds-in-directory directory collect)
+ (collect-sub*directories-asd-files
+ directory :exclude exclude :collect collect))))
+
+(asdefs "2.16"
+ (defun load-sysdef (name pathname)
+ (declare (ignore name))
+ (let ((package (asdf::make-temporary-package)))
+ (unwind-protect
+ (let ((*package* package)
+ (*default-pathname-defaults*
+ (asdf::pathname-directory-pathname
+ (translate-logical-pathname pathname))))
+ (asdf::asdf-message
+ "~&; Loading system definition from ~A into ~A~%" ;
+ pathname package)
+ (load pathname))
+ (delete-package package))))
+
+ (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
+ (apply 'directory pathname-spec
+ (append keys
+ '#.(or #+allegro
+ '(:directories-are-files nil
+ :follow-symbolic-links nil)
+ #+clozure
+ '(:follow-links nil)
+ #+clisp
+ '(:circle t :if-does-not-exist :ignore)
+ #+(or cmu scl)
+ '(:follow-links nil :truenamep nil)
+ #+sbcl
+ (when (find-symbol "RESOLVE-SYMLINKS" '#:sb-impl)
+ '(:resolve-symlinks nil)))))))
+(asdefs "2.17"
+ (defun collect-sub*directories-asd-files
+ (directory &key
+ (exclude asdf::*default-source-registry-exclusions*)
+ collect)
+ (asdf::collect-sub*directories
+ directory
+ (constantly t)
+ (lambda (x) (not (member (car (last (pathname-directory x)))
+ exclude :test #'equal)))
+ (lambda (dir) (collect-asds-in-directory dir collect))))
+
+ (defun system-source-directory (system-designator)
+ (asdf::pathname-directory-pathname
+ (asdf::system-source-file system-designator)))
+
+ (defun filter-logical-directory-results (directory entries merger)
+ (if (typep directory 'logical-pathname)
+ (loop for f in entries
+ when
+ (if (typep f 'logical-pathname)
+ f
+ (let ((u (ignore-errors (funcall merger f))))
+ (and u
+ (equal (ignore-errors (truename u))
+ (truename f))
+ u)))
+ collect it)
+ entries))
+
+ (defun directory-asd-files (directory)
+ (directory-files directory asdf::*wild-asd*)))
+
+(asdefs "2.19"
+ (defun subdirectories (directory)
+ (let* ((directory (asdf::ensure-directory-pathname directory))
+ #-(or abcl cormanlisp xcl)
+ (wild (asdf::merge-pathnames*
+ #-(or abcl allegro cmu lispworks sbcl scl xcl)
+ asdf::*wild-directory*
+ #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
+ directory))
+ (dirs
+ #-(or abcl cormanlisp xcl)
+ (ignore-errors
+ (directory* wild . #.(or #+clozure '(:directories t :files nil)
+ #+mcl '(:directories t))))
+ #+(or abcl xcl) (system:list-directory directory)
+ #+cormanlisp (cl::directory-subdirs directory))
+ #+(or abcl allegro cmu lispworks sbcl scl xcl)
+ (dirs (loop for x in dirs
+ for d = #+(or abcl xcl) (extensions:probe-directory x)
+ #+allegro (excl:probe-directory x)
+ #+(or cmu sbcl scl) (asdf::directory-pathname-p x)
+ #+lispworks (lw:file-directory-p x)
+ when d collect #+(or abcl allegro xcl) d
+ #+(or cmu lispworks sbcl scl) x)))
+ (filter-logical-directory-results
+ directory dirs
+ (let ((prefix (or (normalize-pathname-directory-component
+ (pathname-directory directory))
+ ;; because allegro 8.x returns NIL for #p"FOO:"
+ '(:absolute))))
+ (lambda (d)
+ (let ((dir (normalize-pathname-directory-component
+ (pathname-directory d))))
+ (and (consp dir) (consp (cdr dir))
+ (make-pathname
+ :defaults directory :name nil :type nil :version nil
+ :directory
+ (append prefix
+ (make-pathname-component-logical
+ (last dir))))))))))))
+
+(asdefs "2.21"
+ (defun component-loaded-p (c)
+ (and (gethash 'load-op (asdf::component-operation-times
+ (asdf::find-component c nil))) t))
+
+ (defun normalize-pathname-directory-component (directory)
+ (cond
+ #-(or cmu sbcl scl)
+ ((stringp directory) `(:absolute ,directory) directory)
+ ((or (null directory)
+ (and (consp directory)
+ (member (first directory) '(:absolute :relative))))
+ directory)
+ (t
+ (error "Unrecognized pathname directory component ~S" directory))))
+
+ (defun make-pathname-component-logical (x)
+ (typecase x
+ ((eql :unspecific) nil)
+ #+clisp (string (string-upcase x))
+ #+clisp (cons (mapcar 'make-pathname-component-logical x))
+ (t x)))
+
+ (defun make-pathname-logical (pathname host)
+ (make-pathname
+ :host host
+ :directory (make-pathname-component-logical (pathname-directory pathname))
+ :name (make-pathname-component-logical (pathname-name pathname))
+ :type (make-pathname-component-logical (pathname-type pathname))
+ :version (make-pathname-component-logical (pathname-version pathname)))))
+
+(asdefs "2.22"
+ (defun directory-files (directory &optional (pattern asdf::*wild-file*))
+ (let ((dir (pathname directory)))
+ (when (typep dir 'logical-pathname)
+ (when (wild-pathname-p dir)
+ (error "Invalid wild pattern in logical directory ~S" directory))
+ (unless (member (pathname-directory pattern)
+ '(() (:relative)) :test 'equal)
+ (error "Invalid file pattern ~S for logical directory ~S"
+ pattern directory))
+ (setf pattern (make-pathname-logical pattern (pathname-host dir))))
+ (let ((entries (ignore-errors
+ (directory* (asdf::merge-pathnames* pattern dir)))))
+ (filter-logical-directory-results
+ directory entries
+ (lambda (f)
+ (make-pathname :defaults dir
+ :name (make-pathname-component-logical
+ (pathname-name f))
+ :type (make-pathname-component-logical
+ (pathname-type f))
+ :version (make-pathname-component-logical
+ (pathname-version f)))))))))
+
+(asdefs "2.26.149"
+ (defmethod component-relative-pathname ((system asdf:system))
+ (asdf::coerce-pathname
+ (and (slot-boundp system 'asdf::relative-pathname)
+ (slot-value system 'asdf::relative-pathname))
+ :type :directory
+ :defaults (system-source-directory system)))
+ (defun load-asd (pathname &key name &allow-other-keys)
+ (asdf::load-sysdef (or name (string-downcase (pathname-name pathname)))
+ pathname)))
+
+
+;;; Taken from ASDF 1.628
+(defmacro while-collecting ((&rest collectors) &body body)
+ `(asdf::while-collecting ,collectors ,@body))
+
+;;; Now for SLIME-specific stuff
+
+(defun asdf-operation (operation)
+ (or (asdf::find-symbol* operation :asdf)
+ (error "Couldn't find ASDF operation ~S" operation)))
+
+(defun map-system-components (fn system)
+ (map-component-subcomponents fn (asdf:find-system system)))
+
+(defun map-component-subcomponents (fn component)
+ (when component
+ (funcall fn component)
+ (when (typep component 'asdf:module)
+ (dolist (c (asdf:module-components component))
+ (map-component-subcomponents fn c)))))
+
+;;; Maintaining a pathname to component table
+
+(defvar *pathname-component* (make-hash-table :test 'equal))
+
+(defun clear-pathname-component-table ()
+ (clrhash *pathname-component*))
+
+(defun register-system-pathnames (system)
+ (map-system-components 'register-component-pathname system))
+
+(defun recompute-pathname-component-table ()
+ (clear-pathname-component-table)
+ (asdf::map-systems 'register-system-pathnames))
+
+(defun pathname-component (x)
+ (gethash (pathname x) *pathname-component*))
+
+(defmethod asdf:component-pathname :around ((component asdf:component))
+ (let ((p (call-next-method)))
+ (when (pathnamep p)
+ (setf (gethash p *pathname-component*) component))
+ p))
+
+(defun register-component-pathname (component)
+ (asdf:component-pathname component))
+
+(recompute-pathname-component-table)
+
+;;; This is a crude hack, see ASDF's LP #481187.
+(defslimefun who-depends-on (system)
+ (flet ((system-dependencies (op system)
+ (mapcar (lambda (dep)
+ (asdf::coerce-name (if (consp dep) (second dep) dep)))
+ (cdr (assoc op (asdf:component-depends-on op system))))))
+ (let ((system-name (asdf::coerce-name system))
+ (result))
+ (asdf::map-systems
+ (lambda (system)
+ (when (member system-name
+ (system-dependencies 'asdf:load-op system)
+ :test #'string=)
+ (push (asdf:component-name system) result))))
+ result)))
+
+(defmethod xref-doit ((type (eql :depends-on)) thing)
+ (when (typep thing '(or string symbol))
+ (loop for dependency in (who-depends-on thing)
+ for asd-file = (asdf:system-definition-pathname dependency)
+ when asd-file
+ collect (list dependency
+ (swank/backend:make-location
+ `(:file ,(namestring asd-file))
+ `(:position 1)
+ `(:snippet ,(format nil "(defsystem :~A" dependency)
+ :align t))))))
+
+(defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
+ "Compile and load SYSTEM using ASDF.
+Record compiler notes signalled as `compiler-condition's."
+ (collect-notes
+ (lambda ()
+ (apply #'operate-on-system system-name operation keywords))))
+
+(defun operate-on-system (system-name operation-name &rest keyword-args)
+ "Perform OPERATION-NAME on SYSTEM-NAME using ASDF.
+The KEYWORD-ARGS are passed on to the operation.
+Example:
+\(operate-on-system \"cl-ppcre\" 'compile-op :force t)"
+ (handler-case
+ (with-compilation-hooks ()
+ (apply #'asdf:operate (asdf-operation operation-name)
+ system-name keyword-args)
+ t)
+ ((or asdf:compile-error #+asdf3 asdf/lisp-build:compile-file-error)
+ () nil)))
+
+(defun unique-string-list (&rest lists)
+ (sort (delete-duplicates (apply #'append lists) :test #'string=) #'string<))
+
+(defslimefun list-all-systems-in-central-registry ()
+ "Returns a list of all systems in ASDF's central registry
+AND in its source-registry. (legacy name)"
+ (unique-string-list
+ (mapcar
+ #'pathname-name
+ (while-collecting (c)
+ (loop for dir in asdf:*central-registry*
+ for defaults = (eval dir)
+ when defaults
+ do (collect-asds-in-directory defaults #'c))
+ (asdf:ensure-source-registry)
+ (if (or #+asdf3 t
+ #-asdf3 (asdf:version-satisfies (asdf:asdf-version) "2.15"))
+ (loop :for k :being :the :hash-keys :of asdf::*source-registry*
+ :do (c k))
+ #-asdf3
+ (dolist (entry (asdf::flatten-source-registry))
+ (destructuring-bind (directory &key recurse exclude) entry
+ (register-asd-directory
+ directory
+ :recurse recurse :exclude exclude :collect #'c))))))))
+
+(defslimefun list-all-systems-known-to-asdf ()
+ "Returns a list of all systems ASDF knows already."
+ (while-collecting (c)
+ (asdf::map-systems (lambda (system) (c (asdf:component-name system))))))
+
+(defslimefun list-asdf-systems ()
+ "Returns the systems in ASDF's central registry and those which ASDF
+already knows."
+ (unique-string-list
+ (list-all-systems-known-to-asdf)
+ (list-all-systems-in-central-registry)))
+
+(defun asdf-component-source-files (component)
+ (while-collecting (c)
+ (labels ((f (x)
+ (typecase x
+ (asdf:source-file (c (asdf:component-pathname x)))
+ (asdf:module (map () #'f (asdf:module-components x))))))
+ (f component))))
+
+(defun asdf-component-output-files (component)
+ (while-collecting (c)
+ (labels ((f (x)
+ (typecase x
+ (asdf:source-file
+ (map () #'c
+ (asdf:output-files (make-instance 'asdf:compile-op) x)))
+ (asdf:module (map () #'f (asdf:module-components x))))))
+ (f component))))
+
+(defslimefun asdf-system-files (name)
+ (let* ((system (asdf:find-system name))
+ (files (mapcar #'namestring
+ (cons
+ (asdf:system-definition-pathname system)
+ (asdf-component-source-files system))))
+ (main-file (find name files
+ :test #'equalp :key #'pathname-name :start 1)))
+ (if main-file
+ (cons main-file (remove main-file files
+ :test #'equal :count 1))
+ files)))
+
+(defslimefun asdf-system-loaded-p (name)
+ (component-loaded-p name))
+
+(defslimefun asdf-system-directory (name)
+ (namestring (asdf:system-source-directory name)))
+
+(defun pathname-system (pathname)
+ (let ((component (pathname-component pathname)))
+ (when component
+ (asdf:component-name (asdf:component-system component)))))
+
+(defslimefun asdf-determine-system (file buffer-package-name)
+ (or
+ (and file
+ (pathname-system file))
+ (and file
+ (progn
+ ;; If not found, let's rebuild the table first
+ (recompute-pathname-component-table)
+ (pathname-system file)))
+ ;; If we couldn't find an already defined system,
+ ;; try finding a system that's named like BUFFER-PACKAGE-NAME.
+ (loop with package = (guess-buffer-package buffer-package-name)
+ for name in (package-names package)
+ for system = (asdf:find-system (asdf::coerce-name name) nil)
+ when (and system
+ (or (not file)
+ (pathname-system file)))
+ return (asdf:component-name system))))
+
+(defslimefun delete-system-fasls (name)
+ (let ((removed-count
+ (loop for file in (asdf-component-output-files
+ (asdf:find-system name))
+ when (probe-file file)
+ count it
+ and
+ do (delete-file file))))
+ (format nil "~d file~:p ~:*~[were~;was~:;were~] removed" removed-count)))
+
+(defvar *recompile-system* nil)
+
+(defmethod asdf:operation-done-p :around
+ ((operation asdf:compile-op)
+ component)
+ (unless (eql *recompile-system*
+ (asdf:component-system component))
+ (call-next-method)))
+
+(defslimefun reload-system (name)
+ (let ((*recompile-system* (asdf:find-system name)))
+ (operate-on-system-for-emacs name 'asdf:load-op)))
+
+;; Doing list-all-systems-in-central-registry might be quite slow
+;; since it accesses a file-system, so run it once at the background
+;; to initialize caches.
+(when (eql *communication-style* :spawn)
+ (spawn (lambda ()
+ (ignore-errors (list-all-systems-in-central-registry)))
+ :name "init-asdf-fs-caches"))
+
+;;; Hook for compile-file-for-emacs
+
+(defun try-compile-file-with-asdf (pathname load-p &rest options)
+ (declare (ignore options))
+ (let ((component (pathname-component pathname)))
+ (when component
+ ;;(format t "~&Compiling ASDF component ~S~%" component)
+ (let ((op (make-instance 'asdf:compile-op)))
+ (with-compilation-hooks ()
+ (asdf:perform op component))
+ (when load-p
+ (asdf:perform (make-instance 'asdf:load-op) component))
+ (values t t nil (first (asdf:output-files op component)))))))
+
+(defun try-compile-asd-file (pathname load-p &rest options)
+ (declare (ignore load-p options))
+ (when (equalp (pathname-type pathname) "asd")
+ (load-asd pathname)
+ (values t t nil pathname)))
+
+(pushnew 'try-compile-asd-file *compile-file-for-emacs-hook*)
+
+;;; (pushnew 'try-compile-file-with-asdf *compile-file-for-emacs-hook*)
+
+(provide :swank-asdf)
diff --git a/vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp b/vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp
new file mode 100644
index 0000000..6a766fb
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-c-p-c.lisp
@@ -0,0 +1,298 @@
+;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion
+;;
+;; Author: Luke Gorrie <luke@synap.se>
+;; Edi Weitz <edi@agharta.de>
+;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+;; Tobias C. Rittweiler <tcr@freebits.de>
+;; and others
+;;
+;; License: Public Domain
+;;
+
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (swank-require :swank-util))
+
+(defslimefun completions (string default-package-name)
+ "Return a list of completions for a symbol designator STRING.
+
+The result is the list (COMPLETION-SET COMPLETED-PREFIX), where
+COMPLETION-SET is the list of all matching completions, and
+COMPLETED-PREFIX is the best (partial) completion of the input
+string.
+
+Simple compound matching is supported on a per-hyphen basis:
+
+ (completions \"m-v-\" \"COMMON-LISP\")
+ ==> ((\"multiple-value-bind\" \"multiple-value-call\"
+ \"multiple-value-list\" \"multiple-value-prog1\"
+ \"multiple-value-setq\" \"multiple-values-limit\")
+ \"multiple-value\")
+
+\(For more advanced compound matching, see FUZZY-COMPLETIONS.)
+
+If STRING is package qualified the result list will also be
+qualified. If string is non-qualified the result strings are
+also not qualified and are considered relative to
+DEFAULT-PACKAGE-NAME.
+
+The way symbols are matched depends on the symbol designator's
+format. The cases are as follows:
+ FOO - Symbols with matching prefix and accessible in the buffer package.
+ PKG:FOO - Symbols with matching prefix and external in package PKG.
+ PKG::FOO - Symbols with matching prefix and accessible in package PKG.
+"
+ (multiple-value-bind (name package-name package internal-p)
+ (parse-completion-arguments string default-package-name)
+ (let* ((symbol-set (symbol-completion-set
+ name package-name package internal-p
+ (make-compound-prefix-matcher #\-)))
+ (package-set (package-completion-set
+ name package-name package internal-p
+ (make-compound-prefix-matcher '(#\. #\-))))
+ (completion-set
+ (format-completion-set (nconc symbol-set package-set)
+ internal-p package-name)))
+ (when completion-set
+ (list completion-set (longest-compound-prefix completion-set))))))
+
+
+;;;;; Find completion set
+
+(defun symbol-completion-set (name package-name package internal-p matchp)
+ "Return the set of completion-candidates as strings."
+ (mapcar (completion-output-symbol-converter name)
+ (and package
+ (mapcar #'symbol-name
+ (find-matching-symbols name
+ package
+ (and (not internal-p)
+ package-name)
+ matchp)))))
+
+(defun package-completion-set (name package-name package internal-p matchp)
+ (declare (ignore package internal-p))
+ (mapcar (completion-output-package-converter name)
+ (and (not package-name)
+ (find-matching-packages name matchp))))
+
+(defun find-matching-symbols (string package external test)
+ "Return a list of symbols in PACKAGE matching STRING.
+TEST is called with two strings. If EXTERNAL is true, only external
+symbols are returned."
+ (let ((completions '())
+ (converter (completion-output-symbol-converter string)))
+ (flet ((symbol-matches-p (symbol)
+ (and (or (not external)
+ (symbol-external-p symbol package))
+ (funcall test string
+ (funcall converter (symbol-name symbol))))))
+ (do-symbols* (symbol package)
+ (when (symbol-matches-p symbol)
+ (push symbol completions))))
+ completions))
+
+(defun find-matching-symbols-in-list (string list test)
+ "Return a list of symbols in LIST matching STRING.
+TEST is called with two strings."
+ (let ((completions '())
+ (converter (completion-output-symbol-converter string)))
+ (flet ((symbol-matches-p (symbol)
+ (funcall test string
+ (funcall converter (symbol-name symbol)))))
+ (dolist (symbol list)
+ (when (symbol-matches-p symbol)
+ (push symbol completions))))
+ (remove-duplicates completions)))
+
+(defun find-matching-packages (name matcher)
+ "Return a list of package names matching NAME with MATCHER.
+MATCHER is a two-argument predicate."
+ (let ((converter (completion-output-package-converter name)))
+ (remove-if-not (lambda (x)
+ (funcall matcher name (funcall converter x)))
+ (mapcar (lambda (pkgname)
+ (concatenate 'string pkgname ":"))
+ (loop for package in (list-all-packages)
+ nconcing (package-names package))))))
+
+
+;; PARSE-COMPLETION-ARGUMENTS return table:
+;;
+;; user behaviour | NAME | PACKAGE-NAME | PACKAGE
+;; ----------------+--------+--------------+-----------------------------------
+;; asdf [tab] | "asdf" | NIL | #<PACKAGE "DEFAULT-PACKAGE-NAME">
+;; | | | or *BUFFER-PACKAGE*
+;; asdf: [tab] | "" | "asdf" | #<PACKAGE "ASDF">
+;; | | |
+;; asdf:foo [tab] | "foo" | "asdf" | #<PACKAGE "ASDF">
+;; | | |
+;; as:fo [tab] | "fo" | "as" | NIL
+;; | | |
+;; : [tab] | "" | "" | #<PACKAGE "KEYWORD">
+;; | | |
+;; :foo [tab] | "foo" | "" | #<PACKAGE "KEYWORD">
+;;
+(defun parse-completion-arguments (string default-package-name)
+ "Parse STRING as a symbol designator.
+Return these values:
+ SYMBOL-NAME
+ PACKAGE-NAME, or nil if the designator does not include an explicit package.
+ PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is
+ NIL, return the respective package of DEFAULT-PACKAGE-NAME instead;
+ if PACKAGE is non-NIL but a package cannot be found under that name,
+ return NIL.)
+ INTERNAL-P, if the symbol is qualified with `::'."
+ (multiple-value-bind (name package-name internal-p)
+ (tokenize-symbol string)
+ (flet ((default-package ()
+ (or (guess-package default-package-name) *buffer-package*)))
+ (let ((package (cond
+ ((not package-name)
+ (default-package))
+ ((equal package-name "")
+ (guess-package (symbol-name :keyword)))
+ ((find-locally-nicknamed-package
+ package-name (default-package)))
+ (t
+ (guess-package package-name)))))
+ (values name package-name package internal-p)))))
+
+(defun completion-output-case-converter (input &optional with-escaping-p)
+ "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case."
+ (ecase (readtable-case *readtable*)
+ (:upcase (cond ((or with-escaping-p
+ (and (plusp (length input))
+ (not (some #'lower-case-p input))))
+ #'identity)
+ (t #'string-downcase)))
+ (:invert (lambda (output)
+ (multiple-value-bind (lower upper) (determine-case output)
+ (cond ((and lower upper) output)
+ (lower (string-upcase output))
+ (upper (string-downcase output))
+ (t output)))))
+ (:downcase (cond ((or with-escaping-p
+ (and (zerop (length input))
+ (not (some #'upper-case-p input))))
+ #'identity)
+ (t #'string-upcase)))
+ (:preserve #'identity)))
+
+(defun completion-output-package-converter (input)
+ "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case."
+ (completion-output-case-converter input))
+
+(defun completion-output-symbol-converter (input)
+ "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case. Escape symbols when needed."
+ (let ((case-converter (completion-output-case-converter input))
+ (case-converter-with-escaping (completion-output-case-converter input t)))
+ (lambda (str)
+ (if (or (multiple-value-bind (lowercase uppercase)
+ (determine-case str)
+ ;; In these readtable cases, symbols with letters from
+ ;; the wrong case need escaping
+ (case (readtable-case *readtable*)
+ (:upcase lowercase)
+ (:downcase uppercase)
+ (t nil)))
+ (some (lambda (el)
+ (or (member el '(#\: #\Space #\Newline #\Tab))
+ (multiple-value-bind (macrofun nonterminating)
+ (get-macro-character el)
+ (and macrofun
+ (not nonterminating)))))
+ str))
+ (concatenate 'string "|" (funcall case-converter-with-escaping str) "|")
+ (funcall case-converter str)))))
+
+
+(defun determine-case (string)
+ "Return two booleans LOWER and UPPER indicating whether STRING
+contains lower or upper case characters."
+ (values (some #'lower-case-p string)
+ (some #'upper-case-p string)))
+
+
+;;;;; Compound-prefix matching
+
+(defun make-compound-prefix-matcher (delimiter &key (test #'char=))
+ "Returns a matching function that takes a `prefix' and a
+`target' string and which returns T if `prefix' is a
+compound-prefix of `target', and otherwise NIL.
+
+Viewing each of `prefix' and `target' as a series of substrings
+delimited by DELIMITER, if each substring of `prefix' is a prefix
+of the corresponding substring in `target' then we call `prefix'
+a compound-prefix of `target'.
+
+DELIMITER may be a character, or a list of characters."
+ (let ((delimiters (etypecase delimiter
+ (character (list delimiter))
+ (cons (assert (every #'characterp delimiter))
+ delimiter))))
+ (lambda (prefix target)
+ (declare (type simple-string prefix target))
+ (loop with tpos = 0
+ for ch across prefix
+ always (and (< tpos (length target))
+ (let ((delimiter (car (member ch delimiters :test test))))
+ (if delimiter
+ (setf tpos (position delimiter target :start tpos))
+ (funcall test ch (aref target tpos)))))
+ do (incf tpos)))))
+
+
+;;;;; Extending the input string by completion
+
+(defun longest-compound-prefix (completions &optional (delimiter #\-))
+ "Return the longest compound _prefix_ for all COMPLETIONS."
+ (flet ((tokenizer (string) (tokenize-completion string delimiter)))
+ (untokenize-completion
+ (loop for token-list in (transpose-lists (mapcar #'tokenizer completions))
+ if (notevery #'string= token-list (rest token-list))
+ ;; Note that we possibly collect the "" here as well, so that
+ ;; UNTOKENIZE-COMPLETION will append a delimiter for us.
+ collect (longest-common-prefix token-list)
+ and do (loop-finish)
+ else collect (first token-list))
+ delimiter)))
+
+(defun tokenize-completion (string delimiter)
+ "Return all substrings of STRING delimited by DELIMITER."
+ (loop with end
+ for start = 0 then (1+ end)
+ until (> start (length string))
+ do (setq end (or (position delimiter string :start start) (length string)))
+ collect (subseq string start end)))
+
+(defun untokenize-completion (tokens &optional (delimiter #\-))
+ (format nil (format nil "~~{~~A~~^~a~~}" delimiter) tokens))
+
+(defun transpose-lists (lists)
+ "Turn a list-of-lists on its side.
+If the rows are of unequal length, truncate uniformly to the shortest.
+
+For example:
+\(transpose-lists '((ONE TWO THREE) (1 2)))
+ => ((ONE 1) (TWO 2))"
+ (cond ((null lists) '())
+ ((some #'null lists) '())
+ (t (cons (mapcar #'car lists)
+ (transpose-lists (mapcar #'cdr lists))))))
+
+
+;;;; Completion for character names
+
+(defslimefun completions-for-character (prefix)
+ (let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal))
+ (completion-set (character-completion-set prefix matcher))
+ (completions (sort completion-set #'string<)))
+ (list completions (longest-compound-prefix completions #\_))))
+
+(provide :swank-c-p-c)
diff --git a/vim/bundle/slimv/slime/contrib/swank-clipboard.lisp b/vim/bundle/slimv/slime/contrib/swank-clipboard.lisp
new file mode 100644
index 0000000..52b1085
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-clipboard.lisp
@@ -0,0 +1,71 @@
+;;; swank-clipboard.lisp --- Object clipboard
+;;
+;; Written by Helmut Eller in 2008.
+;; License: Public Domain
+
+(defpackage :swank-clipboard
+ (:use :cl)
+ (:import-from :swank :defslimefun :with-buffer-syntax :dcase)
+ (:export :add :delete-entry :entries :entry-to-ref :ref))
+
+(in-package :swank-clipboard)
+
+(defstruct clipboard entries (counter 0))
+
+(defvar *clipboard* (make-clipboard))
+
+(defslimefun add (datum)
+ (let ((value (dcase datum
+ ((:string string package)
+ (with-buffer-syntax (package)
+ (eval (read-from-string string))))
+ ((:inspector part)
+ (swank:inspector-nth-part part))
+ ((:sldb frame var)
+ (swank/backend:frame-var-value frame var)))))
+ (clipboard-add value)
+ (format nil "Added: ~a"
+ (entry-to-string (1- (length (clipboard-entries *clipboard*)))))))
+
+(defslimefun entries ()
+ (loop for (ref . value) in (clipboard-entries *clipboard*)
+ collect `(,ref . ,(to-line value))))
+
+(defslimefun delete-entry (entry)
+ (let ((msg (format nil "Deleted: ~a" (entry-to-string entry))))
+ (clipboard-delete-entry entry)
+ msg))
+
+(defslimefun entry-to-ref (entry)
+ (destructuring-bind (ref . value) (clipboard-entry entry)
+ (list ref (to-line value 5))))
+
+(defun clipboard-add (value)
+ (setf (clipboard-entries *clipboard*)
+ (append (clipboard-entries *clipboard*)
+ (list (cons (incf (clipboard-counter *clipboard*))
+ value)))))
+
+(defun clipboard-ref (ref)
+ (let ((tail (member ref (clipboard-entries *clipboard*) :key #'car)))
+ (cond (tail (cdr (car tail)))
+ (t (error "Invalid clipboard ref: ~s" ref)))))
+
+(defun clipboard-entry (entry)
+ (elt (clipboard-entries *clipboard*) entry))
+
+(defun clipboard-delete-entry (index)
+ (let* ((list (clipboard-entries *clipboard*))
+ (tail (nthcdr index list)))
+ (setf (clipboard-entries *clipboard*)
+ (append (ldiff list tail) (cdr tail)))))
+
+(defun entry-to-string (entry)
+ (destructuring-bind (ref . value) (clipboard-entry entry)
+ (format nil "#@~d(~a)" ref (to-line value))))
+
+(defun to-line (object &optional (width 75))
+ (with-output-to-string (*standard-output*)
+ (write object :right-margin width :lines 1)))
+
+(provide :swank-clipboard)
diff --git a/vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp b/vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp
new file mode 100644
index 0000000..3e46df9
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp
@@ -0,0 +1,1004 @@
+;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects
+;;
+;; Author: Marco Baringer <mb@bese.it> and others
+;; License: Public Domain
+;;
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (swank-require :swank-util))
+
+(defmethod emacs-inspect ((symbol symbol))
+ (let ((package (symbol-package symbol)))
+ (multiple-value-bind (_symbol status)
+ (and package (find-symbol (string symbol) package))
+ (declare (ignore _symbol))
+ (append
+ (label-value-line "Its name is" (symbol-name symbol))
+ ;;
+ ;; Value
+ (cond ((boundp symbol)
+ (append
+ (label-value-line (if (constantp symbol)
+ "It is a constant of value"
+ "It is a global variable bound to")
+ (symbol-value symbol) :newline nil)
+ ;; unbinding constants might be not a good idea, but
+ ;; implementations usually provide a restart.
+ `(" " (:action "[unbind]"
+ ,(lambda () (makunbound symbol))))
+ '((:newline))))
+ (t '("It is unbound." (:newline))))
+ (docstring-ispec "Documentation" symbol 'variable)
+ (multiple-value-bind (expansion definedp) (macroexpand symbol)
+ (if definedp
+ (label-value-line "It is a symbol macro with expansion"
+ expansion)))
+ ;;
+ ;; Function
+ (if (fboundp symbol)
+ (append (if (macro-function symbol)
+ `("It a macro with macro-function: "
+ (:value ,(macro-function symbol)))
+ `("It is a function: "
+ (:value ,(symbol-function symbol))))
+ `(" " (:action "[unbind]"
+ ,(lambda () (fmakunbound symbol))))
+ `((:newline)))
+ `("It has no function value." (:newline)))
+ (docstring-ispec "Function documentation" symbol 'function)
+ (when (compiler-macro-function symbol)
+ (append
+ (label-value-line "It also names the compiler macro"
+ (compiler-macro-function symbol) :newline nil)
+ `(" " (:action "[remove]"
+ ,(lambda ()
+ (setf (compiler-macro-function symbol) nil)))
+ (:newline))))
+ (docstring-ispec "Compiler macro documentation"
+ symbol 'compiler-macro)
+ ;;
+ ;; Package
+ (if package
+ `("It is " ,(string-downcase (string status))
+ " to the package: "
+ (:value ,package ,(package-name package))
+ ,@(if (eq :internal status)
+ `(" "
+ (:action "[export]"
+ ,(lambda () (export symbol package)))))
+ " "
+ (:action "[unintern]"
+ ,(lambda () (unintern symbol package)))
+ (:newline))
+ '("It is a non-interned symbol." (:newline)))
+ ;;
+ ;; Plist
+ (label-value-line "Property list" (symbol-plist symbol))
+ ;;
+ ;; Class
+ (if (find-class symbol nil)
+ `("It names the class "
+ (:value ,(find-class symbol) ,(string symbol))
+ " "
+ (:action "[remove]"
+ ,(lambda () (setf (find-class symbol) nil)))
+ (:newline)))
+ ;;
+ ;; More package
+ (if (find-package symbol)
+ (label-value-line "It names the package" (find-package symbol)))
+ (inspect-type-specifier symbol)))))
+
+#-sbcl
+(defun inspect-type-specifier (symbol)
+ (declare (ignore symbol)))
+
+#+sbcl
+(defun inspect-type-specifier (symbol)
+ (let* ((kind (sb-int:info :type :kind symbol))
+ (fun (case kind
+ (:defined
+ (or (sb-int:info :type :expander symbol) t))
+ (:primitive
+ (or #.(if (swank/sbcl::sbcl-version>= 1 3 1)
+ '(let ((x (sb-int:info :type :expander symbol)))
+ (if (consp x)
+ (car x)
+ x))
+ '(sb-int:info :type :translator symbol))
+ t)))))
+ (when fun
+ (append
+ (list
+ (format nil "It names a ~@[primitive~* ~]type-specifier."
+ (eq kind :primitive))
+ '(:newline))
+ (docstring-ispec "Type-specifier documentation" symbol 'type)
+ (unless (eq t fun)
+ (let ((arglist (arglist fun)))
+ (append
+ `("Type-specifier lambda-list: "
+ ;; Could use ~:s, but inspector-princ does a bit more,
+ ;; and not all NILs in the arglist should be printed that way.
+ ,(if arglist
+ (inspector-princ arglist)
+ "()")
+ (:newline))
+ (multiple-value-bind (expansion ok)
+ (handler-case (sb-ext:typexpand-1 symbol)
+ (error () (values nil nil)))
+ (when ok
+ (list "Type-specifier expansion: "
+ (princ-to-string expansion)))))))))))
+
+(defun docstring-ispec (label object kind)
+ "Return a inspector spec if OBJECT has a docstring of kind KIND."
+ (let ((docstring (documentation object kind)))
+ (cond ((not docstring) nil)
+ ((< (+ (length label) (length docstring))
+ 75)
+ (list label ": " docstring '(:newline)))
+ (t
+ (list label ":" '(:newline) " " docstring '(:newline))))))
+
+(unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil)
+ (defmethod emacs-inspect ((f function))
+ (inspect-function f)))
+
+(defun inspect-function (f)
+ (append
+ (label-value-line "Name" (function-name f))
+ `("Its argument list is: "
+ ,(inspector-princ (arglist f)) (:newline))
+ (docstring-ispec "Documentation" f t)
+ (if (function-lambda-expression f)
+ (label-value-line "Lambda Expression"
+ (function-lambda-expression f)))))
+
+(defun method-specializers-for-inspect (method)
+ "Return a \"pretty\" list of the method's specializers. Normal
+ specializers are replaced by the name of the class, eql
+ specializers are replaced by `(eql ,object)."
+ (mapcar (lambda (spec)
+ (typecase spec
+ (swank-mop:eql-specializer
+ `(eql ,(swank-mop:eql-specializer-object spec)))
+ #-sbcl
+ (t
+ (swank-mop:class-name spec))
+ #+sbcl
+ (t
+ ;; SBCL has extended specializers
+ (let ((gf (sb-mop:method-generic-function method)))
+ (cond (gf
+ (sb-pcl:unparse-specializer-using-class gf spec))
+ ((typep spec 'class)
+ (class-name spec))
+ (t
+ spec))))))
+ (swank-mop:method-specializers method)))
+
+(defun method-for-inspect-value (method)
+ "Returns a \"pretty\" list describing METHOD. The first element
+ of the list is the name of generic-function method is
+ specialiazed on, the second element is the method qualifiers,
+ the rest of the list is the method's specialiazers (as per
+ method-specializers-for-inspect)."
+ (append (list (swank-mop:generic-function-name
+ (swank-mop:method-generic-function method)))
+ (swank-mop:method-qualifiers method)
+ (method-specializers-for-inspect method)))
+
+(defmethod emacs-inspect ((object standard-object))
+ (let ((class (class-of object)))
+ `("Class: " (:value ,class) (:newline)
+ ,@(all-slots-for-inspector object))))
+
+(defvar *gf-method-getter* 'methods-by-applicability
+ "This function is called to get the methods of a generic function.
+The default returns the method sorted by applicability.
+See `methods-by-applicability'.")
+
+(defun specializer< (specializer1 specializer2)
+ "Return true if SPECIALIZER1 is more specific than SPECIALIZER2."
+ (let ((s1 specializer1) (s2 specializer2) )
+ (cond ((typep s1 'swank-mop:eql-specializer)
+ (not (typep s2 'swank-mop:eql-specializer)))
+ ((typep s1 'class)
+ (flet ((cpl (class)
+ (and (swank-mop:class-finalized-p class)
+ (swank-mop:class-precedence-list class))))
+ (member s2 (cpl s1)))))))
+
+(defun methods-by-applicability (gf)
+ "Return methods ordered by most specific argument types.
+
+`method-specializer<' is used for sorting."
+ ;; FIXME: argument-precedence-order and qualifiers are ignored.
+ (labels ((method< (meth1 meth2)
+ (loop for s1 in (swank-mop:method-specializers meth1)
+ for s2 in (swank-mop:method-specializers meth2)
+ do (cond ((specializer< s2 s1) (return nil))
+ ((specializer< s1 s2) (return t))))))
+ (stable-sort (copy-seq (swank-mop:generic-function-methods gf))
+ #'method<)))
+
+(defun abbrev-doc (doc &optional (maxlen 80))
+ "Return the first sentence of DOC, but not more than MAXLAN characters."
+ (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen)))
+ maxlen
+ (length doc))))
+
+(defstruct (inspector-checklist (:conc-name checklist.)
+ (:constructor %make-checklist (buttons)))
+ (buttons nil :type (or null simple-vector))
+ (count 0))
+
+(defun make-checklist (n)
+ (%make-checklist (make-array n :initial-element nil)))
+
+(defun reinitialize-checklist (checklist)
+ ;; Along this counter the buttons are created, so we have to
+ ;; initialize it to 0 everytime the inspector page is redisplayed.
+ (setf (checklist.count checklist) 0)
+ checklist)
+
+(defun make-checklist-button (checklist)
+ (let ((buttons (checklist.buttons checklist))
+ (i (checklist.count checklist)))
+ (incf (checklist.count checklist))
+ `(:action ,(if (svref buttons i)
+ "[X]"
+ "[ ]")
+ ,#'(lambda ()
+ (setf (svref buttons i) (not (svref buttons i))))
+ :refreshp t)))
+
+(defmacro do-checklist ((idx checklist) &body body)
+ "Iterate over all set buttons in CHECKLIST."
+ (let ((buttons (gensym "buttons")))
+ `(let ((,buttons (checklist.buttons ,checklist)))
+ (dotimes (,idx (length ,buttons))
+ (when (svref ,buttons ,idx)
+ ,@body)))))
+
+(defun box (thing) (cons :box thing))
+(defun ref (box)
+ (assert (eq (car box) :box))
+ (cdr box))
+(defun (setf ref) (value box)
+ (assert (eq (car box) :box))
+ (setf (cdr box) value))
+
+(defvar *inspector-slots-default-order* :alphabetically
+ "Accepted values: :alphabetically and :unsorted")
+
+(defvar *inspector-slots-default-grouping* :all
+ "Accepted values: :inheritance and :all")
+
+(defgeneric all-slots-for-inspector (object))
+
+(defmethod all-slots-for-inspector ((object standard-object))
+ (let* ((class (class-of object))
+ (direct-slots (swank-mop:class-direct-slots class))
+ (effective-slots (swank-mop:class-slots class))
+ (longest-slot-name-length
+ (loop for slot :in effective-slots
+ maximize (length (symbol-name
+ (swank-mop:slot-definition-name slot)))))
+ (checklist
+ (reinitialize-checklist
+ (ensure-istate-metadata object :checklist
+ (make-checklist (length effective-slots)))))
+ (grouping-kind
+ ;; We box the value so we can re-set it.
+ (ensure-istate-metadata object :grouping-kind
+ (box *inspector-slots-default-grouping*)))
+ (sort-order
+ (ensure-istate-metadata object :sort-order
+ (box *inspector-slots-default-order*)))
+ (sort-predicate (ecase (ref sort-order)
+ (:alphabetically #'string<)
+ (:unsorted (constantly nil))))
+ (sorted-slots (sort (copy-seq effective-slots)
+ sort-predicate
+ :key #'swank-mop:slot-definition-name))
+ (effective-slots
+ (ecase (ref grouping-kind)
+ (:all sorted-slots)
+ (:inheritance (stable-sort-by-inheritance sorted-slots
+ class sort-predicate)))))
+ `("--------------------"
+ (:newline)
+ " Group slots by inheritance "
+ (:action ,(ecase (ref grouping-kind)
+ (:all "[ ]")
+ (:inheritance "[X]"))
+ ,(lambda ()
+ ;; We have to do this as the order of slots will
+ ;; be sorted differently.
+ (fill (checklist.buttons checklist) nil)
+ (setf (ref grouping-kind)
+ (ecase (ref grouping-kind)
+ (:all :inheritance)
+ (:inheritance :all))))
+ :refreshp t)
+ (:newline)
+ " Sort slots alphabetically "
+ (:action ,(ecase (ref sort-order)
+ (:unsorted "[ ]")
+ (:alphabetically "[X]"))
+ ,(lambda ()
+ (fill (checklist.buttons checklist) nil)
+ (setf (ref sort-order)
+ (ecase (ref sort-order)
+ (:unsorted :alphabetically)
+ (:alphabetically :unsorted))))
+ :refreshp t)
+ (:newline)
+ ,@ (case (ref grouping-kind)
+ (:all
+ `((:newline)
+ "All Slots:"
+ (:newline)
+ ,@(make-slot-listing checklist object class
+ effective-slots direct-slots
+ longest-slot-name-length)))
+ (:inheritance
+ (list-all-slots-by-inheritance checklist object class
+ effective-slots direct-slots
+ longest-slot-name-length)))
+ (:newline)
+ (:action "[set value]"
+ ,(lambda ()
+ (do-checklist (idx checklist)
+ (query-and-set-slot class object
+ (nth idx effective-slots))))
+ :refreshp t)
+ " "
+ (:action "[make unbound]"
+ ,(lambda ()
+ (do-checklist (idx checklist)
+ (swank-mop:slot-makunbound-using-class
+ class object (nth idx effective-slots))))
+ :refreshp t)
+ (:newline))))
+
+(defun list-all-slots-by-inheritance (checklist object class effective-slots
+ direct-slots longest-slot-name-length)
+ (flet ((slot-home-class (slot)
+ (slot-home-class-using-class slot class)))
+ (let ((current-slots '()))
+ (append
+ (loop for slot in effective-slots
+ for previous-home-class = (slot-home-class slot) then home-class
+ for home-class = previous-home-class then (slot-home-class slot)
+ if (eq home-class previous-home-class)
+ do (push slot current-slots)
+ else
+ collect '(:newline)
+ and collect (format nil "~A:" (class-name previous-home-class))
+ and collect '(:newline)
+ and append (make-slot-listing checklist object class
+ (nreverse current-slots)
+ direct-slots
+ longest-slot-name-length)
+ and do (setf current-slots (list slot)))
+ (and current-slots
+ `((:newline)
+ ,(format nil "~A:"
+ (class-name (slot-home-class-using-class
+ (car current-slots) class)))
+ (:newline)
+ ,@(make-slot-listing checklist object class
+ (nreverse current-slots) direct-slots
+ longest-slot-name-length)))))))
+
+(defun make-slot-listing (checklist object class effective-slots direct-slots
+ longest-slot-name-length)
+ (flet ((padding-for (slot-name)
+ (make-string (- longest-slot-name-length (length slot-name))
+ :initial-element #\Space)))
+ (loop
+ for effective-slot :in effective-slots
+ for direct-slot = (find (swank-mop:slot-definition-name effective-slot)
+ direct-slots
+ :key #'swank-mop:slot-definition-name)
+ for slot-name = (inspector-princ
+ (swank-mop:slot-definition-name effective-slot))
+ collect (make-checklist-button checklist)
+ collect " "
+ collect `(:value ,(if direct-slot
+ (list direct-slot effective-slot)
+ effective-slot)
+ ,slot-name)
+ collect (padding-for slot-name)
+ collect " = "
+ collect (slot-value-for-inspector class object effective-slot)
+ collect '(:newline))))
+
+(defgeneric slot-value-for-inspector (class object slot)
+ (:method (class object slot)
+ (let ((boundp (swank-mop:slot-boundp-using-class class object slot)))
+ (if boundp
+ `(:value ,(swank-mop:slot-value-using-class class object slot))
+ "#<unbound>"))))
+
+(defun slot-home-class-using-class (slot class)
+ (let ((slot-name (swank-mop:slot-definition-name slot)))
+ (loop for class in (reverse (swank-mop:class-precedence-list class))
+ thereis (and (member slot-name (swank-mop:class-direct-slots class)
+ :key #'swank-mop:slot-definition-name
+ :test #'eq)
+ class))))
+
+(defun stable-sort-by-inheritance (slots class predicate)
+ (stable-sort slots predicate
+ :key #'(lambda (s)
+ (class-name (slot-home-class-using-class s class)))))
+
+(defun query-and-set-slot (class object slot)
+ (let* ((slot-name (swank-mop:slot-definition-name slot))
+ (value-string (read-from-minibuffer-in-emacs
+ (format nil "Set slot ~S to (evaluated) : "
+ slot-name))))
+ (when (and value-string (not (string= value-string "")))
+ (with-simple-restart (abort "Abort setting slot ~S" slot-name)
+ (setf (swank-mop:slot-value-using-class class object slot)
+ (eval (read-from-string value-string)))))))
+
+
+(defmethod emacs-inspect ((gf standard-generic-function))
+ (flet ((lv (label value) (label-value-line label value)))
+ (append
+ (lv "Name" (swank-mop:generic-function-name gf))
+ (lv "Arguments" (swank-mop:generic-function-lambda-list gf))
+ (docstring-ispec "Documentation" gf t)
+ (lv "Method class" (swank-mop:generic-function-method-class gf))
+ (lv "Method combination"
+ (swank-mop:generic-function-method-combination gf))
+ `("Methods: " (:newline))
+ (loop for method in (funcall *gf-method-getter* gf) append
+ `((:value ,method ,(inspector-princ
+ ;; drop the name of the GF
+ (cdr (method-for-inspect-value method))))
+ " "
+ (:action "[remove method]"
+ ,(let ((m method)) ; LOOP reassigns method
+ (lambda ()
+ (remove-method gf m))))
+ (:newline)))
+ `((:newline))
+ (all-slots-for-inspector gf))))
+
+(defmethod emacs-inspect ((method standard-method))
+ `(,@(if (swank-mop:method-generic-function method)
+ `("Method defined on the generic function "
+ (:value ,(swank-mop:method-generic-function method)
+ ,(inspector-princ
+ (swank-mop:generic-function-name
+ (swank-mop:method-generic-function method)))))
+ '("Method without a generic function"))
+ (:newline)
+ ,@(docstring-ispec "Documentation" method t)
+ "Lambda List: " (:value ,(swank-mop:method-lambda-list method))
+ (:newline)
+ "Specializers: " (:value ,(swank-mop:method-specializers method)
+ ,(inspector-princ
+ (method-specializers-for-inspect method)))
+ (:newline)
+ "Qualifiers: " (:value ,(swank-mop:method-qualifiers method))
+ (:newline)
+ "Method function: " (:value ,(swank-mop:method-function method))
+ (:newline)
+ ,@(all-slots-for-inspector method)))
+
+(defun specializer-direct-methods (class)
+ (sort (copy-seq (swank-mop:specializer-direct-methods class))
+ #'string<
+ :key
+ (lambda (x)
+ (symbol-name
+ (let ((name (swank-mop::generic-function-name
+ (swank-mop::method-generic-function x))))
+ (if (symbolp name)
+ name
+ (second name)))))))
+
+(defmethod emacs-inspect ((class standard-class))
+ `("Name: "
+ (:value ,(class-name class))
+ (:newline)
+ "Super classes: "
+ ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
+ (:newline)
+ "Direct Slots: "
+ ,@(common-seperated-spec
+ (swank-mop:class-direct-slots class)
+ (lambda (slot)
+ `(:value ,slot ,(inspector-princ
+ (swank-mop:slot-definition-name slot)))))
+ (:newline)
+ "Effective Slots: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (common-seperated-spec
+ (swank-mop:class-slots class)
+ (lambda (slot)
+ `(:value ,slot ,(inspector-princ
+ (swank-mop:slot-definition-name slot)))))
+ `("#<N/A (class not finalized)> "
+ (:action "[finalize]"
+ ,(lambda () (swank-mop:finalize-inheritance class)))))
+ (:newline)
+ ,@(let ((doc (documentation class t)))
+ (when doc
+ `("Documentation:" (:newline) ,(inspector-princ doc) (:newline))))
+ "Sub classes: "
+ ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
+ (lambda (sub)
+ `(:value ,sub
+ ,(inspector-princ (class-name sub)))))
+ (:newline)
+ "Precedence List: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (common-seperated-spec
+ (swank-mop:class-precedence-list class)
+ (lambda (class)
+ `(:value ,class ,(inspector-princ (class-name class)))))
+ '("#<N/A (class not finalized)>"))
+ (:newline)
+ ,@(when (swank-mop:specializer-direct-methods class)
+ `("It is used as a direct specializer in the following methods:"
+ (:newline)
+ ,@(loop
+ for method in (specializer-direct-methods class)
+ collect " "
+ collect `(:value ,method
+ ,(inspector-princ
+ (method-for-inspect-value method)))
+ collect '(:newline)
+ if (documentation method t)
+ collect " Documentation: " and
+ collect (abbrev-doc (documentation method t)) and
+ collect '(:newline))))
+ "Prototype: " ,(if (swank-mop:class-finalized-p class)
+ `(:value ,(swank-mop:class-prototype class))
+ '"#<N/A (class not finalized)>")
+ (:newline)
+ ,@(all-slots-for-inspector class)))
+
+(defmethod emacs-inspect ((slot swank-mop:standard-slot-definition))
+ `("Name: "
+ (:value ,(swank-mop:slot-definition-name slot))
+ (:newline)
+ ,@(when (swank-mop:slot-definition-documentation slot)
+ `("Documentation:" (:newline)
+ (:value ,(swank-mop:slot-definition-documentation
+ slot))
+ (:newline)))
+ "Init args: "
+ (:value ,(swank-mop:slot-definition-initargs slot))
+ (:newline)
+ "Init form: "
+ ,(if (swank-mop:slot-definition-initfunction slot)
+ `(:value ,(swank-mop:slot-definition-initform slot))
+ "#<unspecified>")
+ (:newline)
+ "Init function: "
+ (:value ,(swank-mop:slot-definition-initfunction slot))
+ (:newline)
+ ,@(all-slots-for-inspector slot)))
+
+
+;; Wrapper structure over the list of symbols of a package that should
+;; be displayed with their respective classification flags. This is
+;; because we need a unique type to dispatch on in EMACS-INSPECT.
+;; Used by the Inspector for packages.
+(defstruct (%package-symbols-container
+ (:conc-name %container.)
+ (:constructor %%make-package-symbols-container))
+ title ;; A string; the title of the inspector page in Emacs.
+ description ;; A list of renderable objects; used as description.
+ symbols ;; A list of symbols. Supposed to be sorted alphabetically.
+ grouping-kind) ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING
+
+
+(defun %make-package-symbols-container (&key title description symbols)
+ (%%make-package-symbols-container :title title :description description
+ :symbols symbols :grouping-kind :symbol))
+
+(defgeneric make-symbols-listing (grouping-kind symbols))
+
+(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols)
+ "Returns an object renderable by Emacs' inspector side that
+alphabetically lists all the symbols in SYMBOLS together with a
+concise string representation of what each symbol
+represents (see SYMBOL-CLASSIFICATION-STRING)"
+ (let ((max-length (loop for s in symbols
+ maximizing (length (symbol-name s))))
+ (distance 10)) ; empty distance between name and classification
+ (flet ((string-representations (symbol)
+ (let* ((name (symbol-name symbol))
+ (length (length name))
+ (padding (- max-length length)))
+ (values
+ (concatenate 'string
+ name
+ (make-string (+ padding distance)
+ :initial-element #\Space))
+ (symbol-classification-string symbol)))))
+ `("" ; 8 is (length "Symbols:")
+ "Symbols:" ,(make-string (+ -8 max-length distance)
+ :initial-element #\Space)
+ "Flags:"
+ (:newline)
+ ,(concatenate 'string ; underlining dashes
+ (make-string (+ max-length distance -1)
+ :initial-element #\-)
+ " "
+ (symbol-classification-string '#:foo))
+ (:newline)
+ ,@(loop for symbol in symbols appending
+ (multiple-value-bind (symbol-string classification-string)
+ (string-representations symbol)
+ `((:value ,symbol ,symbol-string) ,classification-string
+ (:newline)
+ )))))))
+
+(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols)
+ "For each possible classification (cf. CLASSIFY-SYMBOL), group
+all the symbols in SYMBOLS to all of their respective
+classifications. (If a symbol is, for instance, boundp and a
+generic-function, it'll appear both below the BOUNDP group and
+the GENERIC-FUNCTION group.) As macros and special-operators are
+specified to be FBOUNDP, there is no general FBOUNDP group,
+instead there are the three explicit FUNCTION, MACRO and
+SPECIAL-OPERATOR groups."
+ (let ((table (make-hash-table :test #'eq))
+ (+default-classification+ :misc))
+ (flet ((normalize-classifications (classifications)
+ (cond ((null classifications) `(,+default-classification+))
+ ;; Convert an :FBOUNDP in CLASSIFICATIONS to
+ ;; :FUNCTION if possible.
+ ((and (member :fboundp classifications)
+ (not (member :macro classifications))
+ (not (member :special-operator classifications)))
+ (substitute :function :fboundp classifications))
+ (t (remove :fboundp classifications)))))
+ (loop for symbol in symbols do
+ (loop for classification in
+ (normalize-classifications (classify-symbol symbol))
+ ;; SYMBOLS are supposed to be sorted alphabetically;
+ ;; this property is preserved here except for reversing.
+ do (push symbol (gethash classification table)))))
+ (let* ((classifications (loop for k being each hash-key in table
+ collect k))
+ (classifications (sort classifications
+ ;; Sort alphabetically, except
+ ;; +DEFAULT-CLASSIFICATION+ which
+ ;; sort to the end.
+ (lambda (a b)
+ (cond ((eql a +default-classification+)
+ nil)
+ ((eql b +default-classification+)
+ t)
+ (t (string< a b)))))))
+ (loop for classification in classifications
+ for symbols = (gethash classification table)
+ appending`(,(symbol-name classification)
+ (:newline)
+ ,(make-string 64 :initial-element #\-)
+ (:newline)
+ ,@(mapcan (lambda (symbol)
+ `((:value ,symbol ,(symbol-name symbol))
+ (:newline)))
+ ;; restore alphabetic order.
+ (nreverse symbols))
+ (:newline))))))
+
+(defmethod emacs-inspect ((%container %package-symbols-container))
+ (with-struct (%container. title description symbols grouping-kind) %container
+ `(,title (:newline) (:newline)
+ ,@description
+ (:newline)
+ " " ,(ecase grouping-kind
+ (:symbol
+ `(:action "[Group by classification]"
+ ,(lambda ()
+ (setf grouping-kind :classification))
+ :refreshp t))
+ (:classification
+ `(:action "[Group by symbol]"
+ ,(lambda () (setf grouping-kind :symbol))
+ :refreshp t)))
+ (:newline) (:newline)
+ ,@(make-symbols-listing grouping-kind symbols))))
+
+(defun display-link (type symbols length &key title description)
+ (if (null symbols)
+ (format nil "0 ~A symbols." type)
+ `(:value ,(%make-package-symbols-container :title title
+ :description description
+ :symbols symbols)
+ ,(format nil "~D ~A symbol~P." length type length))))
+
+(defmethod emacs-inspect ((package package))
+ (let ((package-name (package-name package))
+ (package-nicknames (package-nicknames package))
+ (package-use-list (package-use-list package))
+ (package-used-by-list (package-used-by-list package))
+ (shadowed-symbols (package-shadowing-symbols package))
+ (present-symbols '()) (present-symbols-length 0)
+ (internal-symbols '()) (internal-symbols-length 0)
+ (inherited-symbols '()) (inherited-symbols-length 0)
+ (external-symbols '()) (external-symbols-length 0))
+
+ (do-symbols* (sym package)
+ (let ((status (symbol-status sym package)))
+ (when (eq status :inherited)
+ (push sym inherited-symbols) (incf inherited-symbols-length)
+ (go :continue))
+ (push sym present-symbols) (incf present-symbols-length)
+ (cond ((eq status :internal)
+ (push sym internal-symbols) (incf internal-symbols-length))
+ (t
+ (push sym external-symbols) (incf external-symbols-length))))
+ :continue)
+
+ (setf package-nicknames (sort (copy-list package-nicknames)
+ #'string<)
+ package-use-list (sort (copy-list package-use-list)
+ #'string< :key #'package-name)
+ package-used-by-list (sort (copy-list package-used-by-list)
+ #'string< :key #'package-name)
+ shadowed-symbols (sort (copy-list shadowed-symbols)
+ #'string<))
+ ;;; SORT + STRING-LESSP conses on at least SBCL 0.9.18.
+ (setf present-symbols (sort present-symbols #'string<)
+ internal-symbols (sort internal-symbols #'string<)
+ external-symbols (sort external-symbols #'string<)
+ inherited-symbols (sort inherited-symbols #'string<))
+ `("" ;; dummy to preserve indentation.
+ "Name: " (:value ,package-name) (:newline)
+
+ "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline)
+
+ ,@(when (documentation package t)
+ `("Documentation:" (:newline)
+ ,(documentation package t) (:newline)))
+
+ "Use list: " ,@(common-seperated-spec
+ package-use-list
+ (lambda (package)
+ `(:value ,package ,(package-name package))))
+ (:newline)
+
+ "Used by list: " ,@(common-seperated-spec
+ package-used-by-list
+ (lambda (package)
+ `(:value ,package ,(package-name package))))
+ (:newline)
+
+ ,(display-link "present" present-symbols present-symbols-length
+ :title
+ (format nil "All present symbols of package \"~A\""
+ package-name)
+ :description
+ '("A symbol is considered present in a package if it's"
+ (:newline)
+ "\"accessible in that package directly, rather than"
+ (:newline)
+ "being inherited from another package.\""
+ (:newline)
+ "(CLHS glossary entry for `present')"
+ (:newline)))
+
+ (:newline)
+ ,(display-link "external" external-symbols external-symbols-length
+ :title
+ (format nil "All external symbols of package \"~A\""
+ package-name)
+ :description
+ '("A symbol is considered external of a package if it's"
+ (:newline)
+ "\"part of the `external interface' to the package and"
+ (:newline)
+ "[is] inherited by any other package that uses the"
+ (:newline)
+ "package.\" (CLHS glossary entry of `external')"
+ (:newline)))
+ (:newline)
+ ,(display-link "internal" internal-symbols internal-symbols-length
+ :title
+ (format nil "All internal symbols of package \"~A\""
+ package-name)
+ :description
+ '("A symbol is considered internal of a package if it's"
+ (:newline)
+ "present and not external---that is if the package is"
+ (:newline)
+ "the home package of the symbol, or if the symbol has"
+ (:newline)
+ "been explicitly imported into the package."
+ (:newline)
+ (:newline)
+ "Notice that inherited symbols will thus not be listed,"
+ (:newline)
+ "which deliberately deviates from the CLHS glossary"
+ (:newline)
+ "entry of `internal' because it's assumed to be more"
+ (:newline)
+ "useful this way."
+ (:newline)))
+ (:newline)
+ ,(display-link "inherited" inherited-symbols inherited-symbols-length
+ :title
+ (format nil "All inherited symbols of package \"~A\""
+ package-name)
+ :description
+ '("A symbol is considered inherited in a package if it"
+ (:newline)
+ "was made accessible via USE-PACKAGE."
+ (:newline)))
+ (:newline)
+ ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols)
+ :title
+ (format nil "All shadowed symbols of package \"~A\""
+ package-name)
+ :description nil))))
+
+
+(defmethod emacs-inspect ((pathname pathname))
+ `(,(if (wild-pathname-p pathname)
+ "A wild pathname."
+ "A pathname.")
+ (:newline)
+ ,@(label-value-line*
+ ("Namestring" (namestring pathname))
+ ("Host" (pathname-host pathname))
+ ("Device" (pathname-device pathname))
+ ("Directory" (pathname-directory pathname))
+ ("Name" (pathname-name pathname))
+ ("Type" (pathname-type pathname))
+ ("Version" (pathname-version pathname)))
+ ,@ (unless (or (wild-pathname-p pathname)
+ (not (probe-file pathname)))
+ (label-value-line "Truename" (truename pathname)))))
+
+(defmethod emacs-inspect ((pathname logical-pathname))
+ (append
+ (label-value-line*
+ ("Namestring" (namestring pathname))
+ ("Physical pathname: " (translate-logical-pathname pathname)))
+ `("Host: "
+ (:value ,(pathname-host pathname))
+ " ("
+ (:value ,(logical-pathname-translations
+ (pathname-host pathname)))
+ " other translations)"
+ (:newline))
+ (label-value-line*
+ ("Directory" (pathname-directory pathname))
+ ("Name" (pathname-name pathname))
+ ("Type" (pathname-type pathname))
+ ("Version" (pathname-version pathname))
+ ("Truename" (if (not (wild-pathname-p pathname))
+ (probe-file pathname))))))
+
+(defmethod emacs-inspect ((n number))
+ `("Value: " ,(princ-to-string n)))
+
+(defun format-iso8601-time (time-value &optional include-timezone-p)
+ "Formats a universal time TIME-VALUE in ISO 8601 format, with
+ the time zone included if INCLUDE-TIMEZONE-P is non-NIL"
+ ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html
+ ;; Thanks, Nikolai Sandved and Thomas Russ!
+ (flet ((format-iso8601-timezone (zone)
+ (if (zerop zone)
+ "Z"
+ (multiple-value-bind (h m) (truncate (abs zone) 1.0)
+ ;; Tricky. Sign of time zone is reversed in ISO 8601
+ ;; relative to Common Lisp convention!
+ (format nil "~:[+~;-~]~2,'0D:~2,'0D"
+ (> zone 0) h (round (* 60 m)))))))
+ (multiple-value-bind (second minute hour day month year dow dst zone)
+ (decode-universal-time time-value)
+ (declare (ignore dow))
+ (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
+ year month day hour minute second
+ include-timezone-p (format-iso8601-timezone (if dst
+ (+ zone 1)
+ zone))))))
+
+(defmethod emacs-inspect ((i integer))
+ (append
+ `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]"
+ i i i i (ignore-errors (coerce i 'float)))
+ (:newline))
+ (when (< -1 i char-code-limit)
+ (label-value-line "Code-char" (code-char i)))
+ (label-value-line "Integer-length" (integer-length i))
+ (ignore-errors
+ (label-value-line "Universal-time" (format-iso8601-time i t)))))
+
+(defmethod emacs-inspect ((c complex))
+ (label-value-line*
+ ("Real part" (realpart c))
+ ("Imaginary part" (imagpart c))))
+
+(defmethod emacs-inspect ((r ratio))
+ (label-value-line*
+ ("Numerator" (numerator r))
+ ("Denominator" (denominator r))
+ ("As float" (float r))))
+
+(defmethod emacs-inspect ((f float))
+ (cond
+ ((> f most-positive-long-float)
+ (list "Positive infinity."))
+ ((< f most-negative-long-float)
+ (list "Negative infinity."))
+ ((not (= f f))
+ (list "Not a Number."))
+ (t
+ (multiple-value-bind (significand exponent sign) (decode-float f)
+ (append
+ `("Scientific: " ,(format nil "~E" f) (:newline)
+ "Decoded: "
+ (:value ,sign) " * "
+ (:value ,significand) " * "
+ (:value ,(float-radix f)) "^"
+ (:value ,exponent) (:newline))
+ (label-value-line "Digits" (float-digits f))
+ (label-value-line "Precision" (float-precision f)))))))
+
+(defun make-pathname-ispec (pathname position)
+ `("Pathname: "
+ (:value ,pathname)
+ (:newline) " "
+ ,@(when position
+ `((:action "[visit file and show current position]"
+ ,(lambda ()
+ (ed-in-emacs `(,pathname :position ,position :bytep t)))
+ :refreshp nil)
+ (:newline)))))
+
+(defun make-file-stream-ispec (stream)
+ ;; SBCL's socket stream are file-stream but are not associated to
+ ;; any pathname.
+ (let ((pathname (ignore-errors (pathname stream))))
+ (when pathname
+ (make-pathname-ispec pathname (and (open-stream-p stream)
+ (file-position stream))))))
+
+(defmethod emacs-inspect ((stream file-stream))
+ (multiple-value-bind (content)
+ (call-next-method)
+ (append (make-file-stream-ispec stream) content)))
+
+(defmethod emacs-inspect ((condition stream-error))
+ (multiple-value-bind (content)
+ (call-next-method)
+ (let ((stream (stream-error-stream condition)))
+ (append (when (typep stream 'file-stream)
+ (make-file-stream-ispec stream))
+ content))))
+
+(defun common-seperated-spec (list &optional (callback (lambda (v)
+ `(:value ,v))))
+ (butlast
+ (loop
+ for i in list
+ collect (funcall callback i)
+ collect ", ")))
+
+(defun inspector-princ (list)
+ "Like princ-to-string, but don't rewrite (function foo) as #'foo.
+Do NOT pass circular lists to this function."
+ (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
+ (set-pprint-dispatch '(cons (member function)) nil)
+ (princ-to-string list)))
+
+(provide :swank-fancy-inspector)
diff --git a/vim/bundle/slimv/slime/contrib/swank-fuzzy.lisp b/vim/bundle/slimv/slime/contrib/swank-fuzzy.lisp
new file mode 100644
index 0000000..bfd274f
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-fuzzy.lisp
@@ -0,0 +1,706 @@
+;;; swank-fuzzy.lisp --- fuzzy symbol completion
+;;
+;; Authors: Brian Downing <bdowning@lavos.net>
+;; Tobias C. Rittweiler <tcr@freebits.de>
+;; and others
+;;
+;; License: Public Domain
+;;
+
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (swank-require :swank-util)
+ (swank-require :swank-c-p-c))
+
+(defvar *fuzzy-duplicate-symbol-filter* :nearest-package
+ "Specifies how fuzzy-matching handles \"duplicate\" symbols.
+Possible values are :NEAREST-PACKAGE, :HOME-PACKAGE, :ALL, or a custom
+function. See Fuzzy Completion in the manual for details.")
+
+(export '*fuzzy-duplicate-symbol-filter*)
+
+;;; For nomenclature of the fuzzy completion section, please read
+;;; through the following docstring.
+
+(defslimefun fuzzy-completions (string default-package-name
+ &key limit time-limit-in-msec)
+"Returns a list of two values:
+
+ An (optionally limited to LIMIT best results) list of fuzzy
+ completions for a symbol designator STRING. The list will be
+ sorted by score, most likely match first.
+
+ A flag that indicates whether or not TIME-LIMIT-IN-MSEC has
+ been exhausted during computation. If that parameter's value is
+ NIL or 0, no time limit is assumed.
+
+The main result is a list of completion objects, where a completion
+object is:
+
+ (COMPLETED-STRING SCORE (&rest CHUNKS) CLASSIFICATION-STRING)
+
+where a CHUNK is a description of a matched substring:
+
+ (OFFSET SUBSTRING)
+
+and FLAGS is short string describing properties of the symbol (see
+SYMBOL-CLASSIFICATION-STRING).
+
+E.g., completing \"mvb\" in a package that uses COMMON-LISP would
+return something like:
+
+ ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\"))
+ (:FBOUNDP :MACRO))
+ ...)
+
+If STRING is package qualified the result list will also be
+qualified. If string is non-qualified the result strings are
+also not qualified and are considered relative to
+DEFAULT-PACKAGE-NAME.
+
+Which symbols are candidates for matching depends on the symbol
+designator's format. The cases are as follows:
+ FOO - Symbols accessible in the buffer package.
+ PKG:FOO - Symbols external in package PKG.
+ PKG::FOO - Symbols accessible in package PKG."
+ ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC
+ ;; to denote an infinite time limit. Internally, we only use NIL for
+ ;; that purpose, to be able to distinguish between "no time limit
+ ;; alltogether" and "current time limit already exhausted." So we've
+ ;; got to canonicalize its value at first:
+ (let* ((no-time-limit-p (or (not time-limit-in-msec)
+ (zerop time-limit-in-msec)))
+ (time-limit (if no-time-limit-p nil time-limit-in-msec)))
+ (multiple-value-bind (completion-set interrupted-p)
+ (fuzzy-completion-set string default-package-name :limit limit
+ :time-limit-in-msec time-limit)
+ ;; We may send this as elisp [] arrays to spare a coerce here,
+ ;; but then the network serialization were slower by handling arrays.
+ ;; Instead we limit the number of completions that is transferred
+ ;; (the limit is set from Emacs.)
+ (list (coerce completion-set 'list) interrupted-p))))
+
+
+;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion
+;;; object that will be sent back to Emacs, as described above.
+
+(defstruct (fuzzy-matching (:conc-name fuzzy-matching.)
+ (:predicate fuzzy-matching-p)
+ (:constructor make-fuzzy-matching
+ (symbol package-name score package-chunks
+ symbol-chunks &key (symbol-p t))))
+ symbol ; The symbol that has been found to match.
+ symbol-p ; To deffirentiate between completeing
+ ; package: and package:nil
+ package-name ; The name of the package where SYMBOL was found in.
+ ; (This is not necessarily the same as the home-package
+ ; of SYMBOL, because the SYMBOL can be internal to
+ ; lots of packages; also think of package nicknames.)
+ score ; The higher the better SYMBOL is a match.
+ package-chunks ; Chunks pertaining to the package identifier of SYMBOL.
+ symbol-chunks) ; Chunks pertaining to SYMBOL's name.
+
+(defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string)
+ (multiple-value-bind (_ user-package-name __ input-internal-p)
+ (parse-completion-arguments user-input-string nil)
+ (declare (ignore _ __))
+ (with-struct (fuzzy-matching. score symbol package-name package-chunks
+ symbol-chunks symbol-p)
+ fuzzy-matching
+ (let (symbol-name real-package-name internal-p)
+ (cond (symbol-p ; symbol fuzzy matching?
+ (setf symbol-name (symbol-name symbol))
+ (setf internal-p input-internal-p)
+ (setf real-package-name (cond ((keywordp symbol) "")
+ ((not user-package-name) nil)
+ (t package-name))))
+ (t ; package fuzzy matching?
+ (setf symbol-name "")
+ (setf real-package-name package-name)
+ ;; If no explicit package name was given by the user
+ ;; (e.g. input was "asdf"), we want to append only
+ ;; one colon ":" to the package names.
+ (setf internal-p (if user-package-name input-internal-p nil))))
+ (values symbol-name
+ real-package-name
+ (if user-package-name internal-p nil)
+ (completion-output-symbol-converter user-input-string)
+ (completion-output-package-converter user-input-string))))))
+
+(defun fuzzy-format-matching (fuzzy-matching user-input-string)
+ "Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING."
+ (multiple-value-bind (symbol-name package-name internal-p
+ symbol-converter package-converter)
+ (%fuzzy-extract-matching-info fuzzy-matching user-input-string)
+ (setq symbol-name (and symbol-name
+ (funcall symbol-converter symbol-name)))
+ (setq package-name (and package-name
+ (funcall package-converter package-name)))
+ (let ((result (untokenize-symbol package-name internal-p symbol-name)))
+ ;; We return the length of the possibly added prefix as second value.
+ (values result (search symbol-name result)))))
+
+(defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string)
+ "Converts a result from the fuzzy completion core into something
+that emacs is expecting. Converts symbols to strings, fixes case
+issues, and adds information (as a string) describing if the symbol is
+bound, fbound, a class, a macro, a generic-function, a
+special-operator, or a package."
+ (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks
+ symbol-p)
+ fuzzy-matching
+ (multiple-value-bind (name added-length)
+ (fuzzy-format-matching fuzzy-matching user-input-string)
+ (list name
+ (format nil "~,2f" score)
+ (append package-chunks
+ (mapcar (lambda (chunk)
+ ;; Fix up chunk positions to account for possible
+ ;; added package identifier.
+ (let ((offset (first chunk))
+ (string (second chunk)))
+ (list (+ added-length offset) string)))
+ symbol-chunks))
+ (if symbol-p
+ (symbol-classification-string symbol)
+ "-------p")))))
+
+(defun fuzzy-completion-set (string default-package-name
+ &key limit time-limit-in-msec)
+ "Returns two values: an array of completion objects, sorted by
+their score, that is how well they are a match for STRING
+according to the fuzzy completion algorithm. If LIMIT is set,
+only the top LIMIT results will be returned. Additionally, a flag
+is returned that indicates whether or not TIME-LIMIT-IN-MSEC was
+exhausted."
+ (check-type limit (or null (integer 0 #.(1- most-positive-fixnum))))
+ (check-type time-limit-in-msec
+ (or null (integer 0 #.(1- most-positive-fixnum))))
+ (multiple-value-bind (matchings interrupted-p)
+ (fuzzy-generate-matchings string default-package-name time-limit-in-msec)
+ (when (and limit
+ (> limit 0)
+ (< limit (length matchings)))
+ (if (array-has-fill-pointer-p matchings)
+ (setf (fill-pointer matchings) limit)
+ (setf matchings (make-array limit :displaced-to matchings))))
+ (map-into matchings #'(lambda (m)
+ (fuzzy-convert-matching-for-emacs m string))
+ matchings)
+ (values matchings interrupted-p)))
+
+
+(defun fuzzy-generate-matchings (string default-package-name
+ time-limit-in-msec)
+ "Does all the hard work for FUZZY-COMPLETION-SET. If
+TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed."
+ (multiple-value-bind (parsed-symbol-name parsed-package-name
+ package internal-p)
+ (parse-completion-arguments string default-package-name)
+ (flet ((fix-up (matchings parent-package-matching)
+ ;; The components of each matching in MATCHINGS have been computed
+ ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute.
+ (let* ((p parent-package-matching)
+ (p.name (fuzzy-matching.package-name p))
+ (p.score (fuzzy-matching.score p))
+ (p.chunks (fuzzy-matching.package-chunks p)))
+ (map-into
+ matchings
+ (lambda (m)
+ (let ((m.score (fuzzy-matching.score m)))
+ (setf (fuzzy-matching.package-name m) p.name)
+ (setf (fuzzy-matching.package-chunks m) p.chunks)
+ (setf (fuzzy-matching.score m)
+ (if (equal parsed-symbol-name "")
+ ;; Make package matchings be sorted before all
+ ;; the relative symbol matchings while preserving
+ ;; over all orderness.
+ (/ p.score 100)
+ (+ p.score m.score)))
+ m))
+ matchings)))
+ (find-symbols (designator package time-limit &optional filter)
+ (fuzzy-find-matching-symbols designator package
+ :time-limit-in-msec time-limit
+ :external-only (not internal-p)
+ :filter (or filter #'identity)))
+ (find-packages (designator time-limit)
+ (fuzzy-find-matching-packages designator
+ :time-limit-in-msec time-limit))
+ (maybe-find-local-package (name)
+ (or (find-locally-nicknamed-package name *buffer-package*)
+ (find-package name))))
+ (let ((time-limit time-limit-in-msec) (symbols) (packages) (results)
+ (dedup-table (make-hash-table :test #'equal)))
+ (cond ((not parsed-package-name) ; E.g. STRING = "asd"
+ ;; We don't know if user is searching for a package or a symbol
+ ;; within his current package. So we try to find either.
+ (setf (values packages time-limit)
+ (find-packages parsed-symbol-name time-limit))
+ (setf (values symbols time-limit)
+ (find-symbols parsed-symbol-name package time-limit)))
+ ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo"
+ (setf (values symbols time-limit)
+ (find-symbols parsed-symbol-name package time-limit)))
+ (t ; E.g. STRING = "asd:" or "asd:foo"
+ ;; Find fuzzy matchings of the denoted package identifier part.
+ ;; After that, find matchings for the denoted symbol identifier
+ ;; relative to all the packages found.
+ (multiple-value-bind (symbol-packages rest-time-limit)
+ (find-packages parsed-package-name time-limit-in-msec)
+ ;; We want to traverse the found packages in the order of
+ ;; their score, since those with higher score presumably
+ ;; represent better choices. (This is important because some
+ ;; packages may never be looked at if time limit exhausts
+ ;; during traversal.)
+ (setf symbol-packages
+ (sort symbol-packages #'fuzzy-matching-greaterp))
+ (loop
+ for package-matching across symbol-packages
+ for package = (maybe-find-local-package
+ (fuzzy-matching.package-name
+ package-matching))
+ while (or (not time-limit) (> rest-time-limit 0)) do
+ (multiple-value-bind (matchings remaining-time)
+ ;; The duplication filter removes all those symbols
+ ;; which are present in more than one package
+ ;; match. See *FUZZY-DUPLICATE-SYMBOL-FILTER*
+ (find-symbols parsed-symbol-name package rest-time-limit
+ (%make-duplicate-symbols-filter
+ package-matching symbol-packages dedup-table))
+ (setf matchings (fix-up matchings package-matching))
+ (setf symbols (concatenate 'vector symbols matchings))
+ (setf rest-time-limit remaining-time)
+ (let ((guessed-sort-duration
+ (%guess-sort-duration (length symbols))))
+ (when (and rest-time-limit
+ (<= rest-time-limit guessed-sort-duration))
+ (decf rest-time-limit guessed-sort-duration)
+ (loop-finish))))
+ finally
+ (setf time-limit rest-time-limit)
+ (when (equal parsed-symbol-name "") ; E.g. STRING = "asd:"
+ (setf packages symbol-packages))))))
+ ;; Sort by score; thing with equal score, sort alphabetically.
+ ;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all
+ ;; possible completions are to be returned.)
+ (setf results (concatenate 'vector symbols packages))
+ (setf results (sort results #'fuzzy-matching-greaterp))
+ (values results (and time-limit (<= time-limit 0)))))))
+
+(defun %guess-sort-duration (length)
+ ;; These numbers are pretty much arbitrary, except that they're
+ ;; vaguely correct on my machine with SBCL. Yes, this is an ugly
+ ;; kludge, but it's better than before (where this didn't exist at
+ ;; all, which essentially meant, that this was taken to be 0.)
+ (if (zerop length)
+ 0
+ (let ((comparasions (* 3.8 (* length (log length 2)))))
+ (* 1000 (* comparasions (expt 10 -7)))))) ; msecs
+
+(defun %make-duplicate-symbols-filter (current-package-matching fuzzy-package-matchings dedup-table)
+ ;; Returns a filter function based on *FUZZY-DUPLICATE-SYMBOL-FILTER*.
+ (case *fuzzy-duplicate-symbol-filter*
+ (:home-package
+ ;; Return a filter function that takes a symbol, and which returns T
+ ;; if and only if /no/ matching in FUZZY-PACKAGE-MATCHINGS represents
+ ;; the home-package of the symbol passed.
+ (let ((packages (mapcar #'(lambda (m)
+ (find-package (fuzzy-matching.package-name m)))
+ (remove current-package-matching
+ (coerce fuzzy-package-matchings 'list)))))
+ #'(lambda (symbol)
+ (not (member (symbol-package symbol) packages)))))
+ (:nearest-package
+ ;; Keep only the first occurence of the symbol.
+ #'(lambda (symbol)
+ (unless (gethash (symbol-name symbol) dedup-table)
+ (setf (gethash (symbol-name symbol) dedup-table) t))))
+ (:all
+ ;; No filter
+ #'identity)
+ (t
+ (typecase *fuzzy-duplicate-symbol-filter*
+ (function
+ ;; Custom filter
+ (funcall *fuzzy-duplicate-symbol-filter*
+ (fuzzy-matching.package-name current-package-matching)
+ (map 'list #'fuzzy-matching.package-name fuzzy-package-matchings)
+ dedup-table))
+ (t
+ ;; Bad filter value
+ (warn "bad *FUZZY-DUPLICATE-SYMBOL-FILTER* value: ~s"
+ *fuzzy-duplicate-symbol-filter*)
+ #'identity)))))
+
+(defun fuzzy-matching-greaterp (m1 m2)
+ "Returns T if fuzzy-matching M1 should be sorted before M2.
+Basically just the scores of the two matchings are compared, and
+the match with higher score wins. For the case that the score is
+equal, the one which comes alphabetically first wins."
+ (declare (type fuzzy-matching m1 m2))
+ (let ((score1 (fuzzy-matching.score m1))
+ (score2 (fuzzy-matching.score m2)))
+ (cond ((> score1 score2) t)
+ ((< score1 score2) nil) ; total order
+ (t
+ (let ((name1 (symbol-name (fuzzy-matching.symbol m1)))
+ (name2 (symbol-name (fuzzy-matching.symbol m2))))
+ (string< name1 name2))))))
+
+(declaim (ftype (function () (integer 0)) get-real-time-msecs))
+(defun get-real-time-in-msecs ()
+ (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000))))
+ (values (floor (get-internal-real-time) units-per-msec))))
+
+(defun fuzzy-find-matching-symbols
+ (string package &key (filter #'identity) external-only time-limit-in-msec)
+ "Returns two values: a vector of fuzzy matchings for matching
+symbols in PACKAGE, using the fuzzy completion algorithm, and the
+remaining time limit.
+
+Only those symbols are considered of which FILTER does return T.
+
+If EXTERNAL-ONLY is true, only external symbols are considered. A
+TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or
+negative, perform a NOP."
+ (let ((time-limit-p (and time-limit-in-msec t))
+ (time-limit (or time-limit-in-msec 0))
+ (rtime-at-start (get-real-time-in-msecs))
+ (package-name (package-name package))
+ (count 0))
+ (declare (type boolean time-limit-p))
+ (declare (type integer time-limit rtime-at-start))
+ (declare (type (integer 0 #.(1- most-positive-fixnum)) count))
+
+ (flet ((recompute-remaining-time (old-remaining-time)
+ (cond ((not time-limit-p)
+ ;; propagate NIL back as infinite time limit
+ (values nil nil))
+ ((> count 0) ; ease up on getting internal time like crazy
+ (setf count (mod (1+ count) 128))
+ (values nil old-remaining-time))
+ (t (let* ((elapsed-time (- (get-real-time-in-msecs)
+ rtime-at-start))
+ (remaining (- time-limit elapsed-time)))
+ (values (<= remaining 0) remaining)))))
+ (perform-fuzzy-match (string symbol-name)
+ (let* ((converter (completion-output-symbol-converter string))
+ (converted-symbol-name (funcall converter symbol-name)))
+ (compute-highest-scoring-completion string
+ converted-symbol-name))))
+ (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
+ (rest-time-limit time-limit))
+ (do-symbols* (symbol package)
+ (multiple-value-bind (exhausted? remaining-time)
+ (recompute-remaining-time rest-time-limit)
+ (setf rest-time-limit remaining-time)
+ (cond (exhausted? (return))
+ ((not (and (or (not external-only)
+ (symbol-external-p symbol package))
+ (funcall filter symbol))))
+ ((string= "" string) ; "" matches always
+ (vector-push-extend
+ (make-fuzzy-matching symbol package-name
+ 0.0 '() '())
+ completions))
+ (t
+ (multiple-value-bind (match-result score)
+ (perform-fuzzy-match string (symbol-name symbol))
+ (when match-result
+ (vector-push-extend
+ (make-fuzzy-matching symbol package-name score
+ '() match-result)
+ completions)))))))
+ (values completions rest-time-limit)))))
+
+(defun fuzzy-find-matching-packages (name &key time-limit-in-msec)
+ "Returns a vector of fuzzy matchings for each package that is
+similiar to NAME, and the remaining time limit.
+Cf. FUZZY-FIND-MATCHING-SYMBOLS."
+ (let ((time-limit-p (and time-limit-in-msec t))
+ (time-limit (or time-limit-in-msec 0))
+ (rtime-at-start (get-real-time-in-msecs))
+ (converter (completion-output-package-converter name))
+ (completions (make-array 32 :adjustable t :fill-pointer 0)))
+ (declare (type boolean time-limit-p))
+ (declare (type integer time-limit rtime-at-start))
+ (declare (type function converter))
+ (flet ((match-package (names)
+ (loop with max-pkg-name = ""
+ with max-result = nil
+ with max-score = 0
+ for package-name in names
+ for converted-name = (funcall converter package-name)
+ do
+ (multiple-value-bind (result score)
+ (compute-highest-scoring-completion name
+ converted-name)
+ (when (and result (> score max-score))
+ (setf max-pkg-name package-name)
+ (setf max-result result)
+ (setf max-score score)))
+ finally
+ (when max-result
+ (vector-push-extend
+ (make-fuzzy-matching nil max-pkg-name
+ max-score max-result '()
+ :symbol-p nil)
+ completions)))))
+ (cond ((and time-limit-p (<= time-limit 0))
+ (values #() time-limit))
+ (t
+ (loop for (nick) in (package-local-nicknames *buffer-package*)
+ do
+ (match-package (list nick)))
+ (loop for package in (list-all-packages)
+ do
+ ;; Find best-matching package-nickname:
+ (match-package (package-names package))
+ finally
+ (return
+ (values completions
+ (and time-limit-p
+ (let ((elapsed-time (- (get-real-time-in-msecs)
+ rtime-at-start)))
+ (- time-limit elapsed-time)))))))))))
+
+
+(defslimefun fuzzy-completion-selected (original-string completion)
+ "This function is called by Slime when a fuzzy completion is
+selected by the user. It is for future expansion to make
+testing, say, a machine learning algorithm for completion scoring
+easier.
+
+ORIGINAL-STRING is the string the user completed from, and
+COMPLETION is the completion object (see docstring for
+SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the
+user selected."
+ (declare (ignore original-string completion))
+ nil)
+
+
+;;;;; Fuzzy completion core
+
+(defparameter *fuzzy-recursion-soft-limit* 30
+ "This is a soft limit for recursion in
+RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit,
+completing a string such as \"ZZZZZZ\" with a symbol named
+\"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to
+find all the ways it can match.
+
+Most natural language searches and symbols do not have this
+problem -- this is only here as a safeguard.")
+(declaim (fixnum *fuzzy-recursion-soft-limit*))
+
+(defvar *all-chunks* '())
+(declaim (type list *all-chunks*))
+
+(defun compute-highest-scoring-completion (short full)
+ "Finds the highest scoring way to complete the abbreviation
+SHORT onto the string FULL, using CHAR= as a equality function for
+letters. Returns two values: The first being the completion
+chunks of the highest scorer, and the second being the score."
+ (let* ((scored-results
+ (mapcar #'(lambda (result)
+ (cons (score-completion result short full) result))
+ (compute-most-completions short full)))
+ (winner (first (sort scored-results #'> :key #'first))))
+ (values (rest winner) (first winner))))
+
+(defun compute-most-completions (short full)
+ "Finds most possible ways to complete FULL with the letters in SHORT.
+Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns
+a list of (&rest CHUNKS), where each CHUNKS is a description of
+how a completion matches."
+ (let ((*all-chunks* nil))
+ (recursively-compute-most-completions short full 0 0 nil nil nil t)
+ *all-chunks*))
+
+(defun recursively-compute-most-completions
+ (short full
+ short-index initial-full-index
+ chunks current-chunk current-chunk-pos
+ recurse-p)
+ "Recursively (if RECURSE-P is true) find /most/ possible ways
+to fuzzily map the letters in SHORT onto FULL, using CHAR= to
+determine if two letters match.
+
+A chunk is a list of elements that have matched consecutively.
+When consecutive matches stop, it is coerced into a string,
+paired with the starting position of the chunk, and pushed onto
+CHUNKS.
+
+Whenever a letter matches, if RECURSE-P is true,
+RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position
+one index ahead, to find other possibly higher scoring
+possibilities. If there are less than
+*FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently,
+this call will also recurse.
+
+Once a word has been completely matched, the chunks are pushed
+onto the special variable *ALL-CHUNKS* and the function returns."
+ (declare (optimize speed)
+ (type fixnum short-index initial-full-index)
+ (type list current-chunk)
+ (simple-string short full))
+ (flet ((short-cur ()
+ "Returns the next letter from the abbreviation, or NIL
+ if all have been used."
+ (if (= short-index (length short))
+ nil
+ (aref short short-index)))
+ (add-to-chunk (char pos)
+ "Adds the CHAR at POS in FULL to the current chunk,
+ marking the start position if it is empty."
+ (unless current-chunk
+ (setf current-chunk-pos pos))
+ (push char current-chunk))
+ (collect-chunk ()
+ "Collects the current chunk to CHUNKS and prepares for
+ a new chunk."
+ (when current-chunk
+ (let ((current-chunk-as-string
+ (nreverse
+ (make-array (length current-chunk)
+ :element-type 'character
+ :initial-contents current-chunk))))
+ (push (list current-chunk-pos current-chunk-as-string) chunks)
+ (setf current-chunk nil
+ current-chunk-pos nil)))))
+ ;; If there's an outstanding chunk coming in collect it. Since
+ ;; we're recursively called on skipping an input character, the
+ ;; chunk can't possibly continue on.
+ (when current-chunk (collect-chunk))
+ (do ((pos initial-full-index (1+ pos)))
+ ((= pos (length full)))
+ (let ((cur-char (aref full pos)))
+ (if (and (short-cur)
+ (char= cur-char (short-cur)))
+ (progn
+ (when recurse-p
+ ;; Try other possibilities, limiting insanely deep
+ ;; recursion somewhat.
+ (recursively-compute-most-completions
+ short full short-index (1+ pos)
+ chunks current-chunk current-chunk-pos
+ (not (> (length *all-chunks*)
+ *fuzzy-recursion-soft-limit*))))
+ (incf short-index)
+ (add-to-chunk cur-char pos))
+ (collect-chunk))))
+ (collect-chunk)
+ ;; If we've exhausted the short characters we have a match.
+ (if (short-cur)
+ nil
+ (let ((rev-chunks (reverse chunks)))
+ (push rev-chunks *all-chunks*)
+ rev-chunks))))
+
+
+;;;;; Fuzzy completion scoring
+
+(defvar *fuzzy-completion-symbol-prefixes* "*+-%&?<"
+ "Letters that are likely to be at the beginning of a symbol.
+Letters found after one of these prefixes will be scored as if
+they were at the beginning of ths symbol.")
+(defvar *fuzzy-completion-symbol-suffixes* "*+->"
+ "Letters that are likely to be at the end of a symbol.
+Letters found before one of these suffixes will be scored as if
+they were at the end of the symbol.")
+(defvar *fuzzy-completion-word-separators* "-/."
+ "Letters that separate different words in symbols. Letters
+after one of these symbols will be scores more highly than other
+letters.")
+
+(defun score-completion (completion short full)
+ "Scores the completion chunks COMPLETION as a completion from
+the abbreviation SHORT to the full string FULL. COMPLETION is a
+list like:
+ ((0 \"mul\") (9 \"v\") (15 \"b\"))
+Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\",
+would indicate that it completed as such (completed letters
+capitalized):
+ MULtiple-Value-Bind
+
+Letters are given scores based on their position in the string.
+Letters at the beginning of a string or after a prefix letter at
+the beginning of a string are scored highest. Letters after a
+word separator such as #\- are scored next highest. Letters at
+the end of a string or before a suffix letter at the end of a
+string are scored medium, and letters anywhere else are scored
+low.
+
+If a letter is directly after another matched letter, and its
+intrinsic value in that position is less than a percentage of the
+previous letter's value, it will use that percentage instead.
+
+Finally, a small scaling factor is applied to favor shorter
+matches, all other things being equal."
+ (labels ((at-beginning-p (pos)
+ (= pos 0))
+ (after-prefix-p (pos)
+ (and (= pos 1)
+ (find (aref full 0) *fuzzy-completion-symbol-prefixes*)))
+ (word-separator-p (pos)
+ (find (aref full pos) *fuzzy-completion-word-separators*))
+ (after-word-separator-p (pos)
+ (find (aref full (1- pos)) *fuzzy-completion-word-separators*))
+ (at-end-p (pos)
+ (= pos (1- (length full))))
+ (before-suffix-p (pos)
+ (and (= pos (- (length full) 2))
+ (find (aref full (1- (length full)))
+ *fuzzy-completion-symbol-suffixes*)))
+ (score-or-percentage-of-previous (base-score pos chunk-pos)
+ (if (zerop chunk-pos)
+ base-score
+ (max base-score
+ (+ (* (score-char (1- pos) (1- chunk-pos)) 0.85)
+ (expt 1.2 chunk-pos)))))
+ (score-char (pos chunk-pos)
+ (score-or-percentage-of-previous
+ (cond ((at-beginning-p pos) 10)
+ ((after-prefix-p pos) 10)
+ ((word-separator-p pos) 1)
+ ((after-word-separator-p pos) 8)
+ ((at-end-p pos) 6)
+ ((before-suffix-p pos) 6)
+ (t 1))
+ pos chunk-pos))
+ (score-chunk (chunk)
+ (loop for chunk-pos below (length (second chunk))
+ for pos from (first chunk)
+ summing (score-char pos chunk-pos))))
+ (let* ((chunk-scores (mapcar #'score-chunk completion))
+ (length-score (/ 10.0 (1+ (- (length full) (length short))))))
+ (values
+ (+ (reduce #'+ chunk-scores) length-score)
+ (list (mapcar #'list chunk-scores completion) length-score)))))
+
+(defun highlight-completion (completion full)
+ "Given a chunk definition COMPLETION and the string FULL,
+HIGHLIGHT-COMPLETION will create a string that demonstrates where
+the completion matched in the string. Matches will be
+capitalized, while the rest of the string will be lower-case."
+ (let ((highlit (nstring-downcase (copy-seq full))))
+ (dolist (chunk completion)
+ (setf highlit (nstring-upcase highlit
+ :start (first chunk)
+ :end (+ (first chunk)
+ (length (second chunk))))))
+ highlit))
+
+(defun format-fuzzy-completion-set (winners)
+ "Given a list of completion objects such as on returned by
+FUZZY-COMPLETION-SET, format the list into user-readable output
+for interactive debugging purpose."
+ (let ((max-len
+ (loop for winner in winners maximizing (length (first winner)))))
+ (loop for (sym score result) in winners do
+ (format t "~&~VA score ~8,2F ~A"
+ max-len (highlight-completion result sym) score result))))
+
+(provide :swank-fuzzy)
diff --git a/vim/bundle/slimv/slime/contrib/swank-hyperdoc.lisp b/vim/bundle/slimv/slime/contrib/swank-hyperdoc.lisp
new file mode 100644
index 0000000..1e34a1d
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-hyperdoc.lisp
@@ -0,0 +1,18 @@
+(in-package :swank)
+
+(defslimefun hyperdoc (string)
+ (let ((hyperdoc-package (find-package :hyperdoc)))
+ (when hyperdoc-package
+ (multiple-value-bind (symbol foundp symbol-name package)
+ (parse-symbol string *buffer-package*)
+ (declare (ignore symbol))
+ (when foundp
+ (funcall (find-symbol (string :lookup) hyperdoc-package)
+ (package-name (if (member package (cons *buffer-package*
+ (package-use-list
+ *buffer-package*)))
+ *buffer-package*
+ package))
+ symbol-name))))))
+
+(provide :swank-hyperdoc)
diff --git a/vim/bundle/slimv/slime/contrib/swank-indentation.lisp b/vim/bundle/slimv/slime/contrib/swank-indentation.lisp
new file mode 100644
index 0000000..67e638d
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-indentation.lisp
@@ -0,0 +1,140 @@
+(in-package :swank)
+
+(defvar *application-hints-tables* '()
+ "A list of hash tables mapping symbols to indentation hints (lists
+of symbols and numbers as per cl-indent.el). Applications can add hash
+tables to the list to change the auto indentation slime sends to
+emacs.")
+
+(defun has-application-indentation-hint-p (symbol)
+ (let ((default (load-time-value (gensym))))
+ (dolist (table *application-hints-tables*)
+ (let ((indentation (gethash symbol table default)))
+ (unless (eq default indentation)
+ (return-from has-application-indentation-hint-p
+ (values indentation t))))))
+ (values nil nil))
+
+(defun application-indentation-hint (symbol)
+ (let ((indentation (has-application-indentation-hint-p symbol)))
+ (labels ((walk (indentation-spec)
+ (etypecase indentation-spec
+ (null nil)
+ (number indentation-spec)
+ (symbol (string-downcase indentation-spec))
+ (cons (cons (walk (car indentation-spec))
+ (walk (cdr indentation-spec)))))))
+ (walk indentation))))
+
+;;; override swank version of this function
+(defun symbol-indentation (symbol)
+ "Return a form describing the indentation of SYMBOL.
+
+The form is to be used as the `common-lisp-indent-function' property
+in Emacs."
+ (cond
+ ((has-application-indentation-hint-p symbol)
+ (application-indentation-hint symbol))
+ ((and (macro-function symbol)
+ (not (known-to-emacs-p symbol)))
+ (let ((arglist (arglist symbol)))
+ (etypecase arglist
+ ((member :not-available)
+ nil)
+ (list
+ (macro-indentation arglist)))))
+ (t nil)))
+
+;;; More complex version.
+(defun macro-indentation (arglist)
+ (labels ((frob (list &optional base)
+ (if (every (lambda (x)
+ (member x '(nil "&rest") :test #'equal))
+ list)
+ ;; If there was nothing interesting, don't return anything.
+ nil
+ ;; Otherwise substitute leading NIL's with 4 or 1.
+ (let ((ok t))
+ (substitute-if (if base
+ 4
+ 1)
+ (lambda (x)
+ (if (and ok (not x))
+ t
+ (setf ok nil)))
+ list))))
+ (walk (list level &optional firstp)
+ (when (consp list)
+ (let ((head (car list)))
+ (if (consp head)
+ (let ((indent (frob (walk head (+ level 1) t))))
+ (cons (list* "&whole" (if (zerop level)
+ 4
+ 1)
+ indent) (walk (cdr list) level)))
+ (case head
+ ;; &BODY is &BODY, this is clear.
+ (&body
+ '("&body"))
+ ;; &KEY is tricksy. If it's at the base level, we want
+ ;; to indent them normally:
+ ;;
+ ;; (foo bar quux
+ ;; :quux t
+ ;; :zot nil)
+ ;;
+ ;; If it's at a destructuring level, we want indent of 1:
+ ;;
+ ;; (with-foo (var arg
+ ;; :foo t
+ ;; :quux nil)
+ ;; ...)
+ (&key
+ (if (zerop level)
+ '("&rest" nil)
+ '("&rest" 1)))
+ ;; &REST is tricksy. If it's at the front of
+ ;; destructuring, we want to indent by 1, otherwise
+ ;; normally:
+ ;;
+ ;; (foo (bar quux
+ ;; zot)
+ ;; ...)
+ ;;
+ ;; but
+ ;;
+ ;; (foo bar quux
+ ;; zot)
+ (&rest
+ (if (and (plusp level) firstp)
+ '("&rest" 1)
+ '("&rest" nil)))
+ ;; &WHOLE and &ENVIRONMENT are skipped as if they weren't there
+ ;; at all.
+ ((&whole &environment)
+ (walk (cddr list) level firstp))
+ ;; &OPTIONAL is indented normally -- and the &OPTIONAL marker
+ ;; itself is not counted.
+ (&optional
+ (walk (cdr list) level))
+ ;; Indent normally, walk the tail -- but
+ ;; unknown lambda-list keywords terminate the walk.
+ (otherwise
+ (unless (member head lambda-list-keywords)
+ (cons nil (walk (cdr list) level))))))))))
+ (frob (walk arglist 0 t) t)))
+
+#+nil
+(progn
+ (assert (equal '(4 4 ("&whole" 4 "&rest" 1) "&body")
+ (macro-indentation '(bar quux (&rest slots) &body body))))
+ (assert (equal nil
+ (macro-indentation '(a b c &rest more))))
+ (assert (equal '(4 4 4 "&body")
+ (macro-indentation '(a b c &body more))))
+ (assert (equal '(("&whole" 4 1 1 "&rest" 1) "&body")
+ (macro-indentation '((name zot &key foo bar) &body body))))
+ (assert (equal nil
+ (macro-indentation '(x y &key z)))))
+
+(provide :swank-indentation)
diff --git a/vim/bundle/slimv/slime/contrib/swank-kawa.scm b/vim/bundle/slimv/slime/contrib/swank-kawa.scm
new file mode 100644
index 0000000..843037b
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-kawa.scm
@@ -0,0 +1,2498 @@
+;;;; swank-kawa.scm --- Swank server for Kawa
+;;;
+;;; Copyright (C) 2007 Helmut Eller
+;;;
+;;; This file is licensed under the terms of the GNU General Public
+;;; License as distributed with Emacs (press C-h C-c for details).
+
+;;;; Installation
+;;
+;; 1. You need Kawa (version 2.x) and a JVM with debugger support.
+;;
+;; 2. Compile this file and create swank-kawa.jar with:
+;; java -cp kawa.jar:$JAVA_HOME/lib/tools.jar \
+;; -Xss2M kawa.repl --r7rs -d classes -C swank-kawa.scm &&
+;; jar cf swank-kawa.jar -C classes .
+;;
+;; 3. Add something like this to your .emacs:
+#|
+;; Kawa, Swank, and the debugger classes (tools.jar) must be in the
+;; classpath. You also need to start the debug agent.
+(setq slime-lisp-implementations
+ '((kawa
+ ("java"
+ ;; needed jar files
+ "-cp" "kawa-2.0.1.jar:swank-kawa.jar:/opt/jdk1.8.0/lib/tools.jar"
+ ;; channel for debugger
+ "-agentlib:jdwp=transport=dt_socket,server=y,suspend=n"
+ ;; depending on JVM, compiler may need more stack
+ "-Xss2M"
+ ;; kawa without GUI
+ "kawa.repl" "-s")
+ :init kawa-slime-init)))
+
+(defun kawa-slime-init (file _)
+ (setq slime-protocol-version 'ignore)
+ (format "%S\n"
+ `(begin (import (swank-kawa))
+ (start-swank ,file)
+ ;; Optionally add source paths of your code so
+ ;; that M-. works better:
+ ;;(set! swank-java-source-path
+ ;; (append
+ ;; '(,(expand-file-name "~/lisp/slime/contrib/")
+ ;; "/scratch/kawa")
+ ;; swank-java-source-path))
+ )))
+
+;; Optionally define a command to start it.
+(defun kawa ()
+ (interactive)
+ (slime 'kawa))
+
+|#
+;; 4. Start everything with M-- M-x slime kawa
+;;
+;;
+
+
+;;; Code:
+
+(define-library (swank macros)
+ (export df fun seq set fin esc
+ ! !! !s @ @s
+ when unless while dotimes dolist for packing with pushf == assert
+ mif mcase mlet mlet* typecase ignore-errors
+ ferror
+ )
+ (import (scheme base)
+ (only (kawa base)
+ syntax
+ quasisyntax
+ syntax-case
+ define-syntax-case
+ identifier?
+
+ invoke
+ invoke-static
+ field
+ static-field
+ instance?
+ try-finally
+ try-catch
+ primitive-throw
+
+ format
+ reverse!
+ as
+ ))
+ (begin "
+("
+
+(define (ferror fstring #!rest args)
+ (let ((err (<java.lang.Error>
+ (as <java.lang.String> (apply format fstring args)))))
+ (primitive-throw err)))
+
+(define (rewrite-lambda-list args)
+ (syntax-case args ()
+ (() #`())
+ ((rest x ...) (eq? #'rest #!rest) args)
+ ((optional x ...) (eq? #'optional #!optional) args)
+ ((var args ...) (identifier? #'var)
+ #`(var #,@(rewrite-lambda-list #'(args ...))))
+ (((var type) args ...) (identifier? #'var)
+ #`((var :: type) #,@(rewrite-lambda-list #'(args ...))))))
+
+(define-syntax df
+ (lambda (stx)
+ (syntax-case stx (=>)
+ ((df name (args ... => return-type) body ...)
+ #`(define (name #,@(rewrite-lambda-list #'(args ...))) :: return-type
+ (seq body ...)))
+ ((df name (args ...) body ...)
+ #`(define (name #,@(rewrite-lambda-list #'(args ...)))
+ (seq body ...))))))
+
+(define-syntax fun
+ (lambda (stx)
+ (syntax-case stx (=>)
+ ((fun (args ... => return-type) body ...)
+ #`(lambda #,(rewrite-lambda-list #'(args ...)) :: return-type
+ (seq body ...)))
+ ((fun (args ...) body ...)
+ #`(lambda #,(rewrite-lambda-list #'(args ...))
+ (seq body ...))))))
+
+(define-syntax fin
+ (syntax-rules ()
+ ((fin body handler ...)
+ (try-finally body (seq handler ...)))))
+
+(define-syntax seq
+ (syntax-rules ()
+ ((seq)
+ (begin #!void))
+ ((seq body ...)
+ (begin body ...))))
+
+(define-syntax esc
+ (syntax-rules ()
+ ((esc abort body ...)
+ (let* ((key (<symbol>))
+ (abort (lambda (val) (throw key val))))
+ (catch key
+ (lambda () body ...)
+ (lambda (key val) val))))))
+
+(define-syntax !
+ (syntax-rules ()
+ ((! name obj args ...)
+ (invoke obj 'name args ...))))
+
+(define-syntax !!
+ (syntax-rules ()
+ ((!! name1 name2 obj args ...)
+ (! name1 (! name2 obj args ...)))))
+
+(define-syntax !s
+ (syntax-rules ()
+ ((! class name args ...)
+ (invoke-static class 'name args ...))))
+
+(define-syntax @
+ (syntax-rules ()
+ ((@ name obj)
+ (field obj 'name))))
+
+(define-syntax @s
+ (syntax-rules (quote)
+ ((@s class name)
+ (static-field class (quote name)))))
+
+(define-syntax while
+ (syntax-rules ()
+ ((while exp body ...)
+ (do () ((not exp)) body ...))))
+
+(define-syntax dotimes
+ (syntax-rules ()
+ ((dotimes (i n result) body ...)
+ (let ((max :: <int> n))
+ (do ((i :: <int> 0 (as <int> (+ i 1))))
+ ((= i max) result)
+ body ...)))
+ ((dotimes (i n) body ...)
+ (dotimes (i n #f) body ...))))
+
+(define-syntax dolist
+ (syntax-rules ()
+ ((dolist (e list) body ... )
+ (for ((e list)) body ...))))
+
+(define-syntax for
+ (syntax-rules ()
+ ((for ((var iterable)) body ...)
+ (let ((iter (! iterator iterable)))
+ (while (! has-next iter)
+ ((lambda (var) body ...)
+ (! next iter)))))))
+
+(define-syntax packing
+ (syntax-rules ()
+ ((packing (var) body ...)
+ (let ((var :: <list> '()))
+ (let ((var (lambda (v) (set! var (cons v var)))))
+ body ...)
+ (reverse! var)))))
+
+;;(define-syntax loop
+;; (syntax-rules (for = then collect until)
+;; ((loop for var = init then step until test collect exp)
+;; (packing (pack)
+;; (do ((var init step))
+;; (test)
+;; (pack exp))))
+;; ((loop while test collect exp)
+;; (packing (pack) (while test (pack exp))))))
+
+(define-syntax with
+ (syntax-rules ()
+ ((with (vars ... (f args ...)) body ...)
+ (f args ... (lambda (vars ...) body ...)))))
+
+(define-syntax pushf
+ (syntax-rules ()
+ ((pushf value var)
+ (set! var (cons value var)))))
+
+(define-syntax ==
+ (syntax-rules ()
+ ((== x y)
+ (eq? x y))))
+
+(define-syntax set
+ (syntax-rules ()
+ ((set x y)
+ (let ((tmp y))
+ (set! x tmp)
+ tmp))
+ ((set x y more ...)
+ (begin (set! x y) (set more ...)))))
+
+(define-syntax assert
+ (syntax-rules ()
+ ((assert test)
+ (seq
+ (when (not test)
+ (error "Assertion failed" 'test))
+ 'ok))
+ ((assert test fstring args ...)
+ (seq
+ (when (not test)
+ (error "Assertion failed" 'test (format #f fstring args ...)))
+ 'ok))))
+
+(define-syntax mif
+ (syntax-rules (quote unquote _)
+ ((mif ('x value) then else)
+ (if (equal? 'x value) then else))
+ ((mif (,x value) then else)
+ (if (eq? x value) then else))
+ ((mif (() value) then else)
+ (if (eq? value '()) then else))
+ #| This variant produces no lambdas but breaks the compiler
+ ((mif ((p . ps) value) then else)
+ (let ((tmp value)
+ (fail? :: <int> 0)
+ (result #!null))
+ (if (instance? tmp <pair>)
+ (let ((tmp :: <pair> tmp))
+ (mif (p (! get-car tmp))
+ (mif (ps (! get-cdr tmp))
+ (set! result then)
+ (set! fail? -1))
+ (set! fail? -1)))
+ (set! fail? -1))
+ (if (= fail? 0) result else)))
+ |#
+ ((mif ((p . ps) value) then else)
+ (let ((fail (lambda () else))
+ (tmp value))
+ (if (instance? tmp <pair>)
+ (let ((tmp :: <pair> tmp))
+ (mif (p (! get-car tmp))
+ (mif (ps (! get-cdr tmp))
+ then
+ (fail))
+ (fail)))
+ (fail))))
+ ((mif (_ value) then else)
+ then)
+ ((mif (var value) then else)
+ (let ((var value)) then))
+ ((mif (pattern value) then)
+ (mif (pattern value) then (values)))))
+
+(define-syntax mcase
+ (syntax-rules ()
+ ((mcase exp (pattern body ...) more ...)
+ (let ((tmp exp))
+ (mif (pattern tmp)
+ (begin body ...)
+ (mcase tmp more ...))))
+ ((mcase exp) (ferror "mcase failed ~s\n~a" 'exp exp))))
+
+(define-syntax mlet
+ (syntax-rules ()
+ ((mlet (pattern value) body ...)
+ (let ((tmp value))
+ (mif (pattern tmp)
+ (begin body ...)
+ (error "mlet failed" tmp))))))
+
+(define-syntax mlet*
+ (syntax-rules ()
+ ((mlet* () body ...) (begin body ...))
+ ((mlet* ((pattern value) ms ...) body ...)
+ (mlet (pattern value) (mlet* (ms ...) body ...)))))
+
+(define-syntax typecase%
+ (syntax-rules (eql or satisfies)
+ ((typecase% var (#t body ...) more ...)
+ (seq body ...))
+ ((typecase% var ((eql value) body ...) more ...)
+ (cond ((eqv? var 'value) body ...)
+ (else (typecase% var more ...))))
+ ((typecase% var ((satisfies predicate) body ...) more ...)
+ (cond ((predicate var) body ...)
+ (else (typecase% var more ...))))
+ ((typecase% var ((or type) body ...) more ...)
+ (typecase% var (type body ...) more ...))
+ ((typecase% var ((or type ...) body ...) more ...)
+ (let ((f (lambda (var) body ...)))
+ (typecase% var
+ (type (f var)) ...
+ (#t (typecase% var more ...)))))
+ ((typecase% var (type body ...) more ...)
+ (cond ((instance? var type)
+ (let ((var :: type (as type var)))
+ body ...))
+ (else (typecase% var more ...))))
+ ((typecase% var)
+ (error "typecase% failed" var
+ (! getClass (as <object> var))))))
+
+(define-syntax typecase
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ exp more ...) (identifier? (syntax exp))
+ #`(typecase% exp more ...))
+ ((_ exp more ...)
+ #`(let ((tmp exp))
+ (typecase% tmp more ...))))))
+
+(define-syntax ignore-errors
+ (syntax-rules ()
+ ((ignore-errors body ...)
+ (try-catch (seq body ...)
+ (v <java.lang.Error> #f)
+ (v <java.lang.Exception> #f)))))
+
+))
+
+(define-library (swank-kawa)
+ (export start-swank
+ create-swank-server
+ swank-java-source-path
+ break)
+ (import (scheme base)
+ (scheme file)
+ (scheme repl)
+ (scheme read)
+ (scheme write)
+ (scheme eval)
+ (scheme process-context)
+ (swank macros)
+ (only (kawa base)
+
+ define-alias
+ define-variable
+
+ define-simple-class
+ this
+
+ invoke-special
+ instance?
+ as
+
+ primitive-throw
+ try-finally
+ try-catch
+ synchronized
+
+ call-with-input-string
+ call-with-output-string
+ force-output
+ format
+
+ make-process
+ command-parse
+
+ runnable
+
+ scheme-implementation-version
+ reverse!
+ )
+ (rnrs hashtables)
+ (only (gnu kawa slib syntaxutils) expand)
+ (only (kawa regex) regex-match))
+ (begin "
+("
+
+
+;;(define-syntax dc
+;; (syntax-rules ()
+;; ((dc name () %% (props ...) prop more ...)
+;; (dc name () %% (props ... (prop <object>)) more ...))
+;; ;;((dc name () %% (props ...) (prop type) more ...)
+;; ;; (dc name () %% (props ... (prop type)) more ...))
+;; ((dc name () %% ((prop type) ...))
+;; (define-simple-class name ()
+;; ((*init* (prop :: type) ...)
+;; (set (field (this) 'prop) prop) ...)
+;; (prop :type type) ...))
+;; ((dc name () props ...)
+;; (dc name () %% () props ...))))
+
+
+;;;; Aliases
+
+(define-alias <server-socket> java.net.ServerSocket)
+(define-alias <socket> java.net.Socket)
+(define-alias <in> java.io.InputStreamReader)
+(define-alias <out> java.io.OutputStreamWriter)
+(define-alias <in-port> gnu.kawa.io.InPort)
+(define-alias <out-port> gnu.kawa.io.OutPort)
+(define-alias <file> java.io.File)
+(define-alias <str> java.lang.String)
+(define-alias <builder> java.lang.StringBuilder)
+(define-alias <throwable> java.lang.Throwable)
+(define-alias <source-error> gnu.text.SourceError)
+(define-alias <module-info> gnu.expr.ModuleInfo)
+(define-alias <iterable> java.lang.Iterable)
+(define-alias <thread> java.lang.Thread)
+(define-alias <queue> java.util.concurrent.LinkedBlockingQueue)
+(define-alias <exchanger> java.util.concurrent.Exchanger)
+(define-alias <timeunit> java.util.concurrent.TimeUnit)
+(define-alias <vm> com.sun.jdi.VirtualMachine)
+(define-alias <mirror> com.sun.jdi.Mirror)
+(define-alias <value> com.sun.jdi.Value)
+(define-alias <thread-ref> com.sun.jdi.ThreadReference)
+(define-alias <obj-ref> com.sun.jdi.ObjectReference)
+(define-alias <array-ref> com.sun.jdi.ArrayReference)
+(define-alias <str-ref> com.sun.jdi.StringReference)
+(define-alias <meth-ref> com.sun.jdi.Method)
+(define-alias <class-type> com.sun.jdi.ClassType)
+(define-alias <ref-type> com.sun.jdi.ReferenceType)
+(define-alias <frame> com.sun.jdi.StackFrame)
+(define-alias <field> com.sun.jdi.Field)
+(define-alias <local-var> com.sun.jdi.LocalVariable)
+(define-alias <location> com.sun.jdi.Location)
+(define-alias <absent-exc> com.sun.jdi.AbsentInformationException)
+(define-alias <event> com.sun.jdi.event.Event)
+(define-alias <exception-event> com.sun.jdi.event.ExceptionEvent)
+(define-alias <step-event> com.sun.jdi.event.StepEvent)
+(define-alias <breakpoint-event> com.sun.jdi.event.BreakpointEvent)
+(define-alias <env> gnu.mapping.Environment)
+
+(define-simple-class <chan> ()
+ (owner :: <thread> #:init (!s java.lang.Thread currentThread))
+ (peer :: <chan>)
+ (queue :: <queue> #:init (<queue>))
+ (lock #:init (<object>)))
+
+
+;;;; Entry Points
+
+(df create-swank-server (port-number)
+ (setup-server port-number announce-port))
+
+(df start-swank (port-file)
+ (let ((announce (fun ((socket <server-socket>))
+ (with (f (call-with-output-file port-file))
+ (format f "~d\n" (! get-local-port socket))))))
+ (spawn (fun ()
+ (setup-server 0 announce)))))
+
+(df setup-server ((port-number <int>) announce)
+ (! set-name (current-thread) "swank")
+ (let ((s (<server-socket> port-number)))
+ (announce s)
+ (let ((c (! accept s)))
+ (! close s)
+ (log "connection: ~s\n" c)
+ (fin (dispatch-events c)
+ (log "closing socket: ~a\n" s)
+ (! close c)))))
+
+(df announce-port ((socket <server-socket>))
+ (log "Listening on port: ~d\n" (! get-local-port socket)))
+
+
+;;;; Event dispatcher
+
+(define-variable *the-vm* #f)
+(define-variable *last-exception* #f)
+(define-variable *last-stacktrace* #f)
+(df %vm (=> <vm>) *the-vm*)
+
+;; FIXME: this needs factorization. But I guess the whole idea of
+;; using bidirectional channels just sucks. Mailboxes owned by a
+;; single thread to which everybody can send are much easier to use.
+
+(df dispatch-events ((s <socket>))
+ (mlet* ((charset "iso-8859-1")
+ (ins (<in> (! getInputStream s) charset))
+ (outs (<out> (! getOutputStream s) charset))
+ ((in . _) (spawn/chan/catch (fun (c) (reader ins c))))
+ ((out . _) (spawn/chan/catch (fun (c) (writer outs c))))
+ ((dbg . _) (spawn/chan/catch vm-monitor))
+ (user-env (interaction-environment))
+ (x (seq
+ (! set-flag user-env #t #|<env>:THREAD_SAFE|# 8)
+ (! set-flag user-env #f #|<env>:DIRECT_INHERITED_ON_SET|# 16)
+ #f))
+ ((listener . _)
+ (spawn/chan (fun (c) (listener c user-env))))
+ (inspector #f)
+ (threads '())
+ (repl-thread #f)
+ (extra '())
+ (vm (let ((vm #f)) (fun () (or vm (rpc dbg `(get-vm)))))))
+ (while #t
+ (mlet ((c . event) (recv* (append (list in out dbg listener)
+ (if inspector (list inspector) '())
+ (map car threads)
+ extra)))
+ ;;(log "event: ~s\n" event)
+ (mcase (list c event)
+ ((_ (':emacs-rex ('|swank:debugger-info-for-emacs| from to)
+ pkg thread id))
+ (send dbg `(debug-info ,thread ,from ,to ,id)))
+ ((_ (':emacs-rex ('|swank:throw-to-toplevel|) pkg thread id))
+ (send dbg `(throw-to-toplevel ,thread ,id)))
+ ((_ (':emacs-rex ('|swank:sldb-continue|) pkg thread id))
+ (send dbg `(thread-continue ,thread ,id)))
+ ((_ (':emacs-rex ('|swank:frame-source-location| frame)
+ pkg thread id))
+ (send dbg `(frame-src-loc ,thread ,frame ,id)))
+ ((_ (':emacs-rex ('|swank:frame-locals-and-catch-tags| frame)
+ pkg thread id))
+ (send dbg `(frame-details ,thread ,frame ,id)))
+ ((_ (':emacs-rex ('|swank:sldb-disassemble| frame)
+ pkg thread id))
+ (send dbg `(disassemble-frame ,thread ,frame ,id)))
+ ((_ (':emacs-rex ('|swank:backtrace| from to) pkg thread id))
+ (send dbg `(thread-frames ,thread ,from ,to ,id)))
+ ((_ (':emacs-rex ('|swank:list-threads|) pkg thread id))
+ (send dbg `(list-threads ,id)))
+ ((_ (':emacs-rex ('|swank:debug-nth-thread| n) _ _ _))
+ (send dbg `(debug-nth-thread ,n)))
+ ((_ (':emacs-rex ('|swank:quit-thread-browser|) _ _ id))
+ (send dbg `(quit-thread-browser ,id)))
+ ((_ (':emacs-rex ('|swank:init-inspector| str . _) pkg _ id))
+ (set inspector (make-inspector user-env (vm)))
+ (send inspector `(init ,str ,id)))
+ ((_ (':emacs-rex ('|swank:inspect-frame-var| frame var)
+ pkg thread id))
+ (mlet ((im . ex) (chan))
+ (set inspector (make-inspector user-env (vm)))
+ (send dbg `(get-local ,ex ,thread ,frame ,var))
+ (send inspector `(init-mirror ,im ,id))))
+ ((_ (':emacs-rex ('|swank:inspect-current-condition|) pkg thread id))
+ (mlet ((im . ex) (chan))
+ (set inspector (make-inspector user-env (vm)))
+ (send dbg `(get-exception ,ex ,thread))
+ (send inspector `(init-mirror ,im ,id))))
+ ((_ (':emacs-rex ('|swank:inspect-nth-part| n) pkg _ id))
+ (send inspector `(inspect-part ,n ,id)))
+ ((_ (':emacs-rex ('|swank:inspector-pop|) pkg _ id))
+ (send inspector `(pop ,id)))
+ ((_ (':emacs-rex ('|swank:quit-inspector|) pkg _ id))
+ (send inspector `(quit ,id)))
+ ((_ (':emacs-interrupt id))
+ (let* ((vm (vm))
+ (t (find-thread id (map cdr threads) repl-thread vm)))
+ (send dbg `(interrupt-thread ,t))))
+ ((_ (':emacs-rex form _ _ id))
+ (send listener `(,form ,id)))
+ ((_ ('get-vm c))
+ (send dbg `(get-vm ,c)))
+ ((_ ('get-channel c))
+ (mlet ((im . ex) (chan))
+ (pushf im extra)
+ (send c ex)))
+ ((_ ('forward x))
+ (send out x))
+ ((_ ('set-listener x))
+ (set repl-thread x))
+ ((_ ('publish-vm vm))
+ (set *the-vm* vm))
+ )))))
+
+(df find-thread (id threads listener (vm <vm>))
+ (cond ((== id ':repl-thread) listener)
+ ((== id 't) listener
+ ;;(if (null? threads)
+ ;; listener
+ ;; (vm-mirror vm (car threads)))
+ )
+ (#t
+ (let ((f (find-if threads
+ (fun (t :: <thread>)
+ (= id (! uniqueID
+ (as <thread-ref> (vm-mirror vm t)))))
+ #f)))
+ (cond (f (vm-mirror vm f))
+ (#t listener))))))
+
+
+;;;; Reader thread
+
+(df reader ((in <in>) (c <chan>))
+ (! set-name (current-thread) "swank-net-reader")
+ (let ((rt (!s gnu.kawa.lispexpr.ReadTable createInitial))) ; ':' not special
+ (while #t
+ (send c (decode-message in rt)))))
+
+(df decode-message ((in <in>) (rt <gnu.kawa.lispexpr.ReadTable>) => <list>)
+ (let* ((header (read-chunk in 6))
+ (len (!s java.lang.Integer parseInt header 16)))
+ (call-with-input-string (read-chunk in len)
+ (fun ((port <input-port>))
+ (%read port rt)))))
+
+(df read-chunk ((in <in>) (len <int>) => <str>)
+ (let ((chars (<char[]> #:length len)))
+ (let loop ((offset :: <int> 0))
+ (cond ((= offset len) (<str> chars))
+ (#t (let ((count (! read in chars offset (- len offset))))
+ (assert (not (= count -1)) "partial packet")
+ (loop (+ offset count))))))))
+
+;;; FIXME: not thread safe
+(df %read ((port <in-port>) (table <gnu.kawa.lispexpr.ReadTable>))
+ (let ((old (!s gnu.kawa.lispexpr.ReadTable getCurrent)))
+ (try-finally
+ (seq (!s gnu.kawa.lispexpr.ReadTable setCurrent table)
+ (read port))
+ (!s gnu.kawa.lispexpr.ReadTable setCurrent old))))
+
+
+;;;; Writer thread
+
+(df writer ((out <out>) (c <chan>))
+ (! set-name (current-thread) "swank-net-writer")
+ (while #t
+ (encode-message out (recv c))))
+
+(df encode-message ((out <out>) (message <list>))
+ (let ((builder (<builder> (as <int> 512))))
+ (print-for-emacs message builder)
+ (! write out (! toString (format "~6,'0x" (! length builder))))
+ (! write out builder)
+ (! flush out)))
+
+(df print-for-emacs (obj (out <builder>))
+ (let ((pr (fun (o) (! append out (! toString (format "~s" o)))))
+ (++ (fun ((s <string>)) (! append out (! toString s)))))
+ (cond ((null? obj) (++ "nil"))
+ ((string? obj) (pr obj))
+ ((number? obj) (pr obj))
+ ;;((keyword? obj) (++ ":") (! append out (to-str obj)))
+ ((symbol? obj) (pr obj))
+ ((pair? obj)
+ (++ "(")
+ (let loop ((obj obj))
+ (print-for-emacs (car obj) out)
+ (let ((cdr (cdr obj)))
+ (cond ((null? cdr) (++ ")"))
+ ((pair? cdr) (++ " ") (loop cdr))
+ (#t (++ " . ") (print-for-emacs cdr out) (++ ")"))))))
+ (#t (error "Unprintable object" obj)))))
+
+;;;; SLIME-EVAL
+
+(df eval-for-emacs ((form <list>) env (id <int>) (c <chan>))
+ ;;(! set-uncaught-exception-handler (current-thread)
+ ;; (<ucex-handler> (fun (t e) (reply-abort c id))))
+ (reply c (%eval form env) id))
+
+(define-variable *slime-funs*)
+(set *slime-funs* (tab))
+
+(df %eval (form env)
+ (apply (lookup-slimefun (car form) *slime-funs*) env (cdr form)))
+
+(df lookup-slimefun ((name <symbol>) tab)
+ ;; name looks like '|swank:connection-info|
+ (or (get tab name #f)
+ (ferror "~a not implemented" name)))
+
+(df %defslimefun ((name <symbol>) (fun <procedure>))
+ (let ((string (symbol->string name)))
+ (cond ((regex-match #/:/ string)
+ (put *slime-funs* name fun))
+ (#t
+ (let ((qname (string->symbol (string-append "swank:" string))))
+ (put *slime-funs* qname fun))))))
+
+(define-syntax defslimefun
+ (syntax-rules ()
+ ((defslimefun name (args ...) body ...)
+ (seq
+ (df name (args ...) body ...)
+ (%defslimefun 'name name)))))
+
+(defslimefun connection-info ((env <env>))
+ (let ((prop (fun (name) (!s java.lang.System getProperty name))))
+ `(:pid
+ 0
+ :style :spawn
+ :lisp-implementation (:type "Kawa" :name "kawa"
+ :version ,(scheme-implementation-version))
+ :machine (:instance ,(prop "java.vm.name") :type ,(prop "os.name")
+ :version ,(prop "java.runtime.version"))
+ :features ()
+ :package (:name "??" :prompt ,(! getName env))
+ :encoding (:coding-systems ("iso-8859-1"))
+ )))
+
+
+;;;; Listener
+
+(df listener ((c <chan>) (env <env>))
+ (! set-name (current-thread) "swank-listener")
+ (log "listener: ~s ~s ~s ~s\n"
+ (current-thread) (! hashCode (current-thread)) c env)
+ (let ((out (make-swank-outport (rpc c `(get-channel)))))
+ (set (current-output-port) out)
+ (let ((vm (as <vm> (rpc c `(get-vm)))))
+ (send c `(set-listener ,(vm-mirror vm (current-thread))))
+ (request-uncaught-exception-events vm)
+ ;;stack snaphost are too expensive
+ ;;(request-caught-exception-events vm)
+ )
+ (rpc c `(get-vm))
+ (listener-loop c env out)))
+
+(define-simple-class <listener-abort> (<throwable>)
+ ((*init*)
+ (invoke-special <throwable> (this) '*init* ))
+ ((abort) :: void
+ (primitive-throw (this))))
+
+(df listener-loop ((c <chan>) (env <env>) port)
+ (while (not (nul? c))
+ ;;(log "listener-loop: ~s ~s\n" (current-thread) c)
+ (mlet ((form id) (recv c))
+ (let ((restart (fun ()
+ (close-port port)
+ (reply-abort c id)
+ (send (car (spawn/chan
+ (fun (cc)
+ (listener (recv cc) env))))
+ c)
+ (set c #!null))))
+ (! set-uncaught-exception-handler (current-thread)
+ (<ucex-handler> (fun (t e) (restart))))
+ (try-catch
+ (let* ((val (%eval form env)))
+ (force-output)
+ (reply c val id))
+ (ex <java.lang.Exception> (invoke-debugger ex) (restart))
+ (ex <java.lang.Error> (invoke-debugger ex) (restart))
+ (ex <listener-abort>
+ (let ((flag (!s java.lang.Thread interrupted)))
+ (log "listener-abort: ~s ~a\n" ex flag))
+ (restart))
+ )))))
+
+(df invoke-debugger (condition)
+ ;;(log "should now invoke debugger: ~a" condition)
+ (try-catch
+ (break condition)
+ (ex <listener-abort> (seq))))
+
+(defslimefun |swank-repl:create-repl| (env #!rest _)
+ (list "user" "user"))
+
+(defslimefun interactive-eval (env str)
+ (values-for-echo-area (eval (read-from-string str) env)))
+
+(defslimefun interactive-eval-region (env (s <string>))
+ (with (port (call-with-input-string s))
+ (values-for-echo-area
+ (let next ((result (values)))
+ (let ((form (read port)))
+ (cond ((== form #!eof) result)
+ (#t (next (eval form env)))))))))
+
+(defslimefun |swank-repl:listener-eval| (env string)
+ (let* ((form (read-from-string string))
+ (list (values-to-list (eval form env))))
+ `(:values ,@(map pprint-to-string list))))
+
+(defslimefun pprint-eval (env string)
+ (let* ((form (read-from-string string))
+ (l (values-to-list (eval form env))))
+ (apply cat (map pprint-to-string l))))
+
+(df call-with-abort (f)
+ (try-catch (f) (ex <throwable> (exception-message ex))))
+
+(df exception-message ((ex <throwable>))
+ (typecase ex
+ (<kawa.lang.NamedException> (! to-string ex))
+ (<throwable> (format "~a: ~a"
+ (class-name-sans-package ex)
+ (! getMessage ex)))))
+
+(df values-for-echo-area (values)
+ (let ((values (values-to-list values)))
+ (cond ((null? values) "; No value")
+ (#t (format "~{~a~^, ~}" (map pprint-to-string values))))))
+
+;;;; Compilation
+
+(defslimefun compile-file-for-emacs (env (filename <str>) load?
+ #!optional options)
+ (let ((jar (cat (path-sans-extension (filepath filename)) ".jar")))
+ (wrap-compilation
+ (fun ((m <gnu.text.SourceMessages>))
+ (!s kawa.lang.CompileFile read filename m))
+ jar (if (lisp-bool load?) env #f) #f)))
+
+(df wrap-compilation (f jar env delete?)
+ (let ((start-time (current-time))
+ (messages (<gnu.text.SourceMessages>)))
+ (try-catch
+ (let ((c (as <gnu.expr.Compilation> (f messages))))
+ (set (@ explicit c) #t)
+ (! compile-to-archive c (! get-module c) jar))
+ (ex <throwable>
+ (log "error during compilation: ~a\n~a" ex (! getStackTrace ex))
+ (! error messages (as <char> #\f)
+ (to-str (exception-message ex)) #!null)
+ #f))
+ (log "compilation done.\n")
+ (let ((success? (zero? (! get-error-count messages))))
+ (when (and env success?)
+ (log "loading ...\n")
+ (eval `(load ,jar) env)
+ (log "loading ... done.\n"))
+ (when delete?
+ (ignore-errors (delete-file jar) #f))
+ (let ((end-time (current-time)))
+ (list ':compilation-result
+ (compiler-notes-for-emacs messages)
+ (if success? 't 'nil)
+ (/ (- end-time start-time) 1000.0))))))
+
+(defslimefun compile-string-for-emacs (env string buffer offset dir)
+ (wrap-compilation
+ (fun ((m <gnu.text.SourceMessages>))
+ (let ((c (as <gnu.expr.Compilation>
+ (call-with-input-string
+ string
+ (fun ((p <in-port>))
+ (! set-path p
+ (format "~s"
+ `(buffer ,buffer offset ,offset str ,string)))
+ (!s kawa.lang.CompileFile read p m))))))
+ (let ((o (@ currentOptions c)))
+ (! set o "warn-invoke-unknown-method" #t)
+ (! set o "warn-undefined-variable" #t))
+ (let ((m (! getModule c)))
+ (! set-name m (format "<emacs>:~a/~a" buffer (current-time))))
+ c))
+ "/tmp/kawa-tmp.zip" env #t))
+
+(df compiler-notes-for-emacs ((messages <gnu.text.SourceMessages>))
+ (packing (pack)
+ (do ((e (! get-errors messages) (@ next e)))
+ ((nul? e))
+ (pack (source-error>elisp e)))))
+
+(df source-error>elisp ((e <source-error>) => <list>)
+ (list ':message (to-string (@ message e))
+ ':severity (case (integer->char (@ severity e))
+ ((#\e #\f) ':error)
+ ((#\w) ':warning)
+ (else ':note))
+ ':location (error-loc>elisp e)))
+
+(df error-loc>elisp ((e <source-error>))
+ (cond ((nul? (@ filename e)) `(:error "No source location"))
+ ((! starts-with (@ filename e) "(buffer ")
+ (mlet (('buffer b 'offset ('quote ((:position o) _)) 'str s)
+ (read-from-string (@ filename e)))
+ (let ((off (line>offset (1- (@ line e)) s))
+ (col (1- (@ column e))))
+ `(:location (:buffer ,b) (:position ,(+ o off col)) nil))))
+ (#t
+ `(:location (:file ,(to-string (@ filename e)))
+ (:line ,(@ line e) ,(1- (@ column e)))
+ nil))))
+
+(df line>offset ((line <int>) (s <str>) => <int>)
+ (let ((offset :: <int> 0))
+ (dotimes (i line)
+ (set offset (! index-of s (as <char> #\newline) offset))
+ (assert (>= offset 0))
+ (set offset (as <int> (+ offset 1))))
+ (log "line=~a offset=~a\n" line offset)
+ offset))
+
+(defslimefun load-file (env filename)
+ (format "Loaded: ~a => ~s" filename (eval `(load ,filename) env)))
+
+;;;; Completion
+
+(defslimefun simple-completions (env (pattern <str>) _)
+ (let* ((env (as <gnu.mapping.InheritingEnvironment> env))
+ (matches (packing (pack)
+ (let ((iter (! enumerate-all-locations env)))
+ (while (! has-next iter)
+ (let ((l (! next-location iter)))
+ (typecase l
+ (<gnu.mapping.NamedLocation>
+ (let ((name (!! get-name get-key-symbol l)))
+ (when (! starts-with name pattern)
+ (pack name)))))))))))
+ `(,matches ,(cond ((null? matches) pattern)
+ (#t (fold+ common-prefix matches))))))
+
+(df common-prefix ((s1 <str>) (s2 <str>) => <str>)
+ (let ((limit (min (! length s1) (! length s2))))
+ (let loop ((i 0))
+ (cond ((or (= i limit)
+ (not (== (! char-at s1 i)
+ (! char-at s2 i))))
+ (! substring s1 0 i))
+ (#t (loop (1+ i)))))))
+
+(df fold+ (f list)
+ (let loop ((s (car list))
+ (l (cdr list)))
+ (cond ((null? l) s)
+ (#t (loop (f s (car l)) (cdr l))))))
+
+;;; Quit
+
+(defslimefun quit-lisp (env)
+ (exit))
+
+;;(defslimefun set-default-directory (env newdir))
+
+
+;;;; Dummy defs
+
+(defslimefun buffer-first-change (#!rest y) '())
+(defslimefun swank-require (#!rest y) '())
+(defslimefun frame-package-name (#!rest y) '())
+
+;;;; arglist
+
+(defslimefun operator-arglist (env name #!rest _)
+ (mcase (try-catch `(ok ,(eval (read-from-string name) env))
+ (ex <throwable> 'nil))
+ (('ok obj)
+ (mcase (arglist obj)
+ ('#f 'nil)
+ ((args rtype)
+ (format "(~a~{~^ ~a~})~a" name
+ (map (fun (e)
+ (if (equal (cadr e) "java.lang.Object") (car e) e))
+ args)
+ (if (equal rtype "java.lang.Object")
+ ""
+ (format " => ~a" rtype))))))
+ (_ 'nil)))
+
+(df arglist (obj)
+ (typecase obj
+ (<gnu.expr.ModuleMethod>
+ (let* ((mref (module-method>meth-ref obj)))
+ (list (mapi (! arguments mref)
+ (fun ((v <local-var>))
+ (list (! name v) (! typeName v))))
+ (! returnTypeName mref))))
+ (<object> #f)))
+
+;;;; M-.
+
+(defslimefun find-definitions-for-emacs (env name)
+ (mcase (try-catch `(ok ,(eval (read-from-string name) env))
+ (ex <throwable> `(error ,(exception-message ex))))
+ (('ok obj) (mapi (all-definitions obj)
+ (fun (d)
+ `(,(format "~a" d) ,(src-loc>elisp (src-loc d))))))
+ (('error msg) `((,name (:error ,msg))))))
+
+(define-simple-class <swank-location> (<location>)
+ (file #:init #f)
+ (line #:init #f)
+ ((*init* file name)
+ (set (@ file (this)) file)
+ (set (@ line (this)) line))
+ ((lineNumber) :: <int> (or line (absent)))
+ ((lineNumber (s :: <str>)) :: int (! lineNumber (this)))
+ ((method) :: <meth-ref> (absent))
+ ((sourcePath) :: <str> (or file (absent)))
+ ((sourcePath (s :: <str>)) :: <str> (! sourcePath (this)))
+ ((sourceName) :: <str> (absent))
+ ((sourceName (s :: <str>)) :: <str> (! sourceName (this)))
+ ((declaringType) :: <ref-type> (absent))
+ ((codeIndex) :: <long> -1)
+ ((virtualMachine) :: <vm> *the-vm*)
+ ((compareTo o) :: <int>
+ (typecase o
+ (<location> (- (! codeIndex (this)) (! codeIndex o))))))
+
+(df absent () (primitive-throw (<absent-exc>)))
+
+(df all-definitions (o)
+ (typecase o
+ (<gnu.expr.ModuleMethod> (list o))
+ (<gnu.expr.PrimProcedure> (list o))
+ (<gnu.expr.GenericProc> (append (mappend all-definitions (gf-methods o))
+ (let ((s (! get-setter o)))
+ (if s (all-definitions s) '()))))
+ (<java.lang.Class> (list o))
+ (<gnu.mapping.Procedure> (all-definitions (! get-class o)))
+ (<kawa.lang.Macro> (list o))
+ (<gnu.bytecode.ObjectType> (all-definitions (! getReflectClass o)))
+ (<java.lang.Object> '())
+ ))
+
+(df gf-methods ((f <gnu.expr.GenericProc>))
+ (let* ((o :: <obj-ref> (vm-mirror *the-vm* f))
+ (f (! field-by-name (! reference-type o) "methods"))
+ (ms (vm-demirror *the-vm* (! get-value o f))))
+ (filter (array-to-list ms) (fun (x) (not (nul? x))))))
+
+(df src-loc (o => <location>)
+ (typecase o
+ (<gnu.expr.PrimProcedure> (src-loc (@ method o)))
+ (<gnu.expr.ModuleMethod> (module-method>src-loc o))
+ (<gnu.expr.GenericProc> (<swank-location> #f #f))
+ (<java.lang.Class> (class>src-loc o))
+ (<kawa.lang.Macro> (<swank-location> #f #f))
+ (<gnu.bytecode.Method> (bytemethod>src-loc o))))
+
+(df module-method>src-loc ((f <gnu.expr.ModuleMethod>))
+ (! location (module-method>meth-ref f)))
+
+(df module-method>meth-ref ((f <gnu.expr.ModuleMethod>) => <meth-ref>)
+ (let* ((module (! reference-type
+ (as <obj-ref> (vm-mirror *the-vm* (@ module f)))))
+ (1st-method-by-name (fun (name)
+ (let ((i (! methods-by-name module name)))
+ (cond ((! is-empty i) #f)
+ (#t (1st i)))))))
+ (as <meth-ref> (or (1st-method-by-name (! get-name f))
+ (let ((mangled (mangled-name f)))
+ (or (1st-method-by-name mangled)
+ (1st-method-by-name (cat mangled "$V"))
+ (1st-method-by-name (cat mangled "$X"))))))))
+
+(df mangled-name ((f <gnu.expr.ModuleMethod>))
+ (let* ((name0 (! get-name f))
+ (name (cond ((nul? name0) (format "lambda~d" (@ selector f)))
+ (#t (!s gnu.expr.Compilation mangleName name0)))))
+ name))
+
+(df class>src-loc ((c <java.lang.Class>) => <location>)
+ (let* ((type (class>ref-type c))
+ (locs (! all-line-locations type)))
+ (cond ((not (! isEmpty locs)) (1st locs))
+ (#t (<swank-location> (1st (! source-paths type "Java"))
+ #f)))))
+
+(df class>ref-type ((class <java.lang.Class>) => <ref-type>)
+ (! reflectedType (as <com.sun.jdi.ClassObjectReference>
+ (vm-mirror *the-vm* class))))
+
+(df class>class-type ((class <java.lang.Class>) => <class-type>)
+ (as <class-type> (class>ref-type class)))
+
+(df bytemethod>src-loc ((m <gnu.bytecode.Method>) => <location>)
+ (let* ((cls (class>class-type (! get-reflect-class
+ (! get-declaring-class m))))
+ (name (! get-name m))
+ (sig (! get-signature m))
+ (meth (! concrete-method-by-name cls name sig)))
+ (! location meth)))
+
+(df src-loc>elisp ((l <location>))
+ (df src-loc>list ((l <location>))
+ (list (ignore-errors (! source-name l "Java"))
+ (ignore-errors (! source-path l "Java"))
+ (ignore-errors (! line-number l "Java"))))
+ (mcase (src-loc>list l)
+ ((name path line)
+ (cond ((not path)
+ `(:error ,(call-with-abort (fun () (! source-path l)))))
+ ((! starts-with (as <str> path) "(buffer ")
+ (mlet (('buffer b 'offset o 'str s) (read-from-string path))
+ `(:location (:buffer ,b)
+ (:position ,(+ o (line>offset line s)))
+ nil)))
+ (#t
+ `(:location ,(or (find-file-in-path name (source-path))
+ (find-file-in-path path (source-path))
+ (ferror "Can't find source-path: ~s ~s ~a"
+ path name (source-path)))
+ (:line ,(or line -1)) ()))))))
+
+(df src-loc>str ((l <location>))
+ (cond ((nul? l) "<null-location>")
+ (#t (format "~a ~a ~a"
+ (or (ignore-errors (! source-path l))
+ (ignore-errors (! source-name l))
+ (ignore-errors (!! name declaring-type l)))
+ (ignore-errors (!! name method l))
+ (ignore-errors (! lineNumber l))))))
+
+;;;;;; class-path hacking
+
+;; (find-file-in-path "kawa/lib/kawa/hashtable.scm" (source-path))
+
+(df find-file-in-path ((filename <str>) (path <list>))
+ (let ((f (<file> filename)))
+ (cond ((! isAbsolute f) `(:file ,filename))
+ (#t (let ((result #f))
+ (find-if path (fun (dir)
+ (let ((x (find-file-in-dir f dir)))
+ (set result x)))
+ #f)
+ result)))))
+
+(df find-file-in-dir ((file <file>) (dir <str>))
+ (let ((filename :: <str> (! getPath file)))
+ (or (let ((child (<file> (<file> dir) filename)))
+ (and (! exists child)
+ `(:file ,(! getPath child))))
+ (try-catch
+ (and (not (nul? (! getEntry (<java.util.zip.ZipFile> dir) filename)))
+ `(:zip ,dir ,filename))
+ (ex <throwable> #f)))))
+
+(define swank-java-source-path
+ (let* ((jre-home :: <str> (!s <java.lang.System> getProperty "java.home"))
+ (parent :: <str> (! get-parent (<file> jre-home))))
+ (list (! get-path (<file> parent "src.zip")))))
+
+(df source-path ()
+ (mlet ((base) (search-path-prop "user.dir"))
+ (append
+ (list base)
+ (map (fun ((s <str>))
+ (let ((f (<file> s))
+ (base :: <str> (as <str> base)))
+ (cond ((! isAbsolute f) s)
+ (#t (! getPath (<file> base s))))))
+ (class-path))
+ swank-java-source-path)))
+
+(df class-path ()
+ (append (search-path-prop "java.class.path")
+ (search-path-prop "sun.boot.class.path")))
+
+(df search-path-prop ((name <str>))
+ (array-to-list (! split (!s java.lang.System getProperty name)
+ (@s <file> pathSeparator))))
+
+;;;; Disassemble
+
+(defslimefun disassemble-form (env form)
+ (mcase (read-from-string form)
+ (('quote name)
+ (let ((f (eval name env)))
+ (typecase f
+ (<gnu.expr.ModuleMethod>
+ (disassemble-to-string (module-method>meth-ref f))))))))
+
+(df disassemble-to-string ((mr <meth-ref>) => <str>)
+ (with-sink #f (fun (out) (disassemble-meth-ref mr out))))
+
+(df disassemble-meth-ref ((mr <meth-ref>) (out <java.io.PrintWriter>))
+ (let* ((t (! declaring-type mr)))
+ (disas-header mr out)
+ (disas-code (! constant-pool t)
+ (! constant-pool-count t)
+ (! bytecodes mr)
+ out)))
+
+(df disas-header ((mr <meth-ref>) (out <java.io.PrintWriter>))
+ (let* ((++ (fun ((str <str>)) (! write out str)))
+ (? (fun (flag str) (if flag (++ str)))))
+ (? (! is-static mr) "static ")
+ (? (! is-final mr) "final ")
+ (? (! is-private mr) "private ")
+ (? (! is-protected mr) "protected ")
+ (? (! is-public mr) "public ")
+ (++ (! name mr)) (++ (! signature mr)) (++ "\n")))
+
+(df disas-code ((cpool <byte[]>) (cpoolcount <int>) (bytecode <byte[]>)
+ (out <java.io.PrintWriter>))
+ (let* ((ct (<gnu.bytecode.ClassType> "foo"))
+ (met (! addMethod ct "bar" 0))
+ (ca (<gnu.bytecode.CodeAttr> met))
+ (constants (let* ((bs (<java.io.ByteArrayOutputStream>))
+ (s (<java.io.DataOutputStream> bs)))
+ (! write-short s cpoolcount)
+ (! write s cpool)
+ (! flush s)
+ (! toByteArray bs))))
+ (vm-set-slot *the-vm* ct "constants"
+ (<gnu.bytecode.ConstantPool>
+ (<java.io.DataInputStream>
+ (<java.io.ByteArrayInputStream>
+ constants))))
+ (! setCode ca bytecode)
+ (let ((w (<gnu.bytecode.ClassTypeWriter> ct out 0)))
+ (! print ca w)
+ (! flush w))))
+
+(df with-sink (sink (f <function>))
+ (cond ((instance? sink <java.io.PrintWriter>) (f sink))
+ ((== sink #t) (f (as <java.io.PrintWriter> (current-output-port))))
+ ((== sink #f)
+ (let* ((buffer (<java.io.StringWriter>))
+ (out (<java.io.PrintWriter> buffer)))
+ (f out)
+ (! flush out)
+ (! toString buffer)))
+ (#t (ferror "Invalid sink designator: ~s" sink))))
+
+(df test-disas ((c <str>) (m <str>))
+ (let* ((vm (as <vm> *the-vm*))
+ (c (as <ref-type> (1st (! classes-by-name vm c))))
+ (m (as <meth-ref> (1st (! methods-by-name c m)))))
+ (with-sink #f (fun (out) (disassemble-meth-ref m out)))))
+
+;; (test-disas "java.lang.Class" "toString")
+
+
+;;;; Macroexpansion
+
+(defslimefun swank-expand-1 (env s) (%swank-macroexpand s env))
+(defslimefun swank-expand (env s) (%swank-macroexpand s env))
+(defslimefun swank-expand-all (env s) (%swank-macroexpand s env))
+
+(df %swank-macroexpand (string env)
+ (pprint-to-string (%macroexpand (read-from-string string) env)))
+
+(df %macroexpand (sexp env) (expand sexp #:env env))
+
+
+;;;; Inspector
+
+(define-simple-class <inspector-state> ()
+ (object #:init #!null)
+ (parts :: <java.util.ArrayList> #:init (<java.util.ArrayList>) )
+ (stack :: <list> #:init '())
+ (content :: <list> #:init '()))
+
+(df make-inspector (env (vm <vm>) => <chan>)
+ (car (spawn/chan (fun (c) (inspector c env vm)))))
+
+(df inspector ((c <chan>) env (vm <vm>))
+ (! set-name (current-thread) "inspector")
+ (let ((state :: <inspector-state> (<inspector-state>))
+ (open #t))
+ (while open
+ (mcase (recv c)
+ (('init str id)
+ (set state (<inspector-state>))
+ (let ((obj (try-catch (eval (read-from-string str) env)
+ (ex <throwable> ex))))
+ (reply c (inspect-object obj state vm) id)))
+ (('init-mirror cc id)
+ (set state (<inspector-state>))
+ (let* ((mirror (recv cc))
+ (obj (vm-demirror vm mirror)))
+ (reply c (inspect-object obj state vm) id)))
+ (('inspect-part n id)
+ (let ((part (! get (@ parts state) n)))
+ (reply c (inspect-object part state vm) id)))
+ (('pop id)
+ (reply c (inspector-pop state vm) id))
+ (('quit id)
+ (reply c 'nil id)
+ (set open #f))))))
+
+(df inspect-object (obj (state <inspector-state>) (vm <vm>))
+ (set (@ object state) obj)
+ (set (@ parts state) (<java.util.ArrayList>))
+ (pushf obj (@ stack state))
+ (set (@ content state) (inspector-content
+ `("class: " (:value ,(! getClass obj)) "\n"
+ ,@(inspect obj vm))
+ state))
+ (cond ((nul? obj) (list ':title "#!null" ':id 0 ':content `()))
+ (#t
+ (list ':title (pprint-to-string obj)
+ ':id (assign-index obj state)
+ ':content (let ((c (@ content state)))
+ (content-range c 0 (len c)))))))
+
+(df inspect (obj vm)
+ (let ((obj (as <obj-ref> (vm-mirror vm obj))))
+ (typecase obj
+ (<array-ref> (inspect-array-ref vm obj))
+ (<obj-ref> (inspect-obj-ref vm obj)))))
+
+(df inspect-array-ref ((vm <vm>) (obj <array-ref>))
+ (packing (pack)
+ (let ((i 0))
+ (for (((v :: <value>) (! getValues obj)))
+ (pack (format "~d: " i))
+ (pack `(:value ,(vm-demirror vm v)))
+ (pack "\n")
+ (set i (1+ i))))))
+
+(df inspect-obj-ref ((vm <vm>) (obj <obj-ref>))
+ (let* ((type (! referenceType obj))
+ (fields (! allFields type))
+ (values (! getValues obj fields))
+ (ifields '()) (sfields '()) (imeths '()) (smeths '())
+ (frob (lambda (lists) (apply append (reverse lists)))))
+ (for (((f :: <field>) fields))
+ (let* ((val (as <value> (! get values f)))
+ (l `(,(! name f) ": " (:value ,(vm-demirror vm val)) "\n")))
+ (if (! is-static f)
+ (pushf l sfields)
+ (pushf l ifields))))
+ (for (((m :: <meth-ref>) (! allMethods type)))
+ (let ((l `(,(! name m) ,(! signature m) "\n")))
+ (if (! is-static m)
+ (pushf l smeths)
+ (pushf l imeths))))
+ `(,@(frob ifields)
+ "--- static fields ---\n" ,@(frob sfields)
+ "--- methods ---\n" ,@(frob imeths)
+ "--- static methods ---\n" ,@(frob smeths))))
+
+(df inspector-content (content (state <inspector-state>))
+ (map (fun (part)
+ (mcase part
+ ((':value val)
+ `(:value ,(pprint-to-string val) ,(assign-index val state)))
+ (x (to-string x))))
+ content))
+
+(df assign-index (obj (state <inspector-state>) => <int>)
+ (! add (@ parts state) obj)
+ (1- (! size (@ parts state))))
+
+(df content-range (l start end)
+ (let* ((len (length l)) (end (min len end)))
+ (list (subseq l start end) len start end)))
+
+(df inspector-pop ((state <inspector-state>) vm)
+ (cond ((<= 2 (len (@ stack state)))
+ (let ((obj (cadr (@ stack state))))
+ (set (@ stack state) (cddr (@ stack state)))
+ (inspect-object obj state vm)))
+ (#t 'nil)))
+
+;;;; IO redirection
+
+(define-simple-class <swank-writer> (<java.io.Writer>)
+ (q :: <queue> #:init (<queue> (as <int> 100)))
+ ((*init*) (invoke-special <java.io.Writer> (this) '*init*))
+ ((write (buffer :: <char[]>) (from :: <int>) (to :: <int>)) :: <void>
+ (synchronized (this)
+ (assert (not (== q #!null)))
+ (! put q `(write ,(<str> buffer from to)))))
+ ((close) :: <void>
+ (synchronized (this)
+ (! put q 'close)
+ (set! q #!null)))
+ ((flush) :: <void>
+ (synchronized (this)
+ (assert (not (== q #!null)))
+ (let ((ex (<exchanger>)))
+ (! put q `(flush ,ex))
+ (! exchange ex #!null)))))
+
+(df swank-writer ((in <chan>) (q <queue>))
+ (! set-name (current-thread) "swank-redirect-thread")
+ (let* ((out (as <chan> (recv in)))
+ (builder (<builder>))
+ (flush (fun ()
+ (unless (zero? (! length builder))
+ (send out `(forward (:write-string ,(<str> builder))))
+ (! setLength builder 0))))
+ (closed #f))
+ (while (not closed)
+ (mcase (! poll q (as long 200) (@s <timeunit> MILLISECONDS))
+ ('#!null (flush))
+ (('write s)
+ (! append builder (as <str> s))
+ (when (> (! length builder) 4000)
+ (flush)))
+ (('flush ex)
+ (flush)
+ (! exchange (as <exchanger> ex) #!null))
+ ('close
+ (set closed #t)
+ (flush))))))
+
+(df make-swank-outport ((out <chan>))
+ (let ((w (<swank-writer>)))
+ (mlet ((in . _) (spawn/chan (fun (c) (swank-writer c (@ q w)))))
+ (send in out))
+ (<out-port> w #t #t)))
+
+
+;;;; Monitor
+
+;;(define-simple-class <monitorstate> ()
+;; (threadmap type: (tab)))
+
+(df vm-monitor ((c <chan>))
+ (! set-name (current-thread) "swank-vm-monitor")
+ (let ((vm (vm-attach)))
+ (log-vm-props vm)
+ (request-breakpoint vm)
+ (mlet* (((ev . _) (spawn/chan/catch
+ (fun (c)
+ (let ((q (! eventQueue vm)))
+ (while #t
+ (send c `(vm-event ,(to-list (! remove q)))))))))
+ (to-string (vm-to-string vm))
+ (state (tab)))
+ (send c `(publish-vm ,vm))
+ (while #t
+ (mcase (recv* (list c ev))
+ ((_ . ('get-vm cc))
+ (send cc vm))
+ ((,c . ('debug-info thread from to id))
+ (reply c (debug-info thread from to state) id))
+ ((,c . ('throw-to-toplevel thread id))
+ (set state (throw-to-toplevel thread id c state)))
+ ((,c . ('thread-continue thread id))
+ (set state (thread-continue thread id c state)))
+ ((,c . ('frame-src-loc thread frame id))
+ (reply c (frame-src-loc thread frame state) id))
+ ((,c . ('frame-details thread frame id))
+ (reply c (list (frame-locals thread frame state) '()) id))
+ ((,c . ('disassemble-frame thread frame id))
+ (reply c (disassemble-frame thread frame state) id))
+ ((,c . ('thread-frames thread from to id))
+ (reply c (thread-frames thread from to state) id))
+ ((,c . ('list-threads id))
+ (reply c (list-threads vm state) id))
+ ((,c . ('interrupt-thread ref))
+ (set state (interrupt-thread ref state c)))
+ ((,c . ('debug-nth-thread n))
+ (let ((t (nth (get state 'all-threads #f) n)))
+ ;;(log "thread ~d : ~a\n" n t)
+ (set state (interrupt-thread t state c))))
+ ((,c . ('quit-thread-browser id))
+ (reply c 't id)
+ (set state (del state 'all-threads)))
+ ((,ev . ('vm-event es))
+ ;;(log "vm-events: len=~a\n" (len es))
+ (for (((e :: <event>) (as <list> es)))
+ (set state (process-vm-event e c state))))
+ ((_ . ('get-exception from tid))
+ (mlet ((_ _ es) (get state tid #f))
+ (send from (let ((e (car es)))
+ (typecase e
+ (<exception-event> (! exception e))
+ (<event> e))))))
+ ((_ . ('get-local rc tid frame var))
+ (send rc (frame-local-var tid frame var state)))
+ )))))
+
+(df reply ((c <chan>) value id)
+ (send c `(forward (:return (:ok ,value) ,id))))
+
+(df reply-abort ((c <chan>) id)
+ (send c `(forward (:return (:abort nil) ,id))))
+
+(df process-vm-event ((e <event>) (c <chan>) state)
+ ;;(log "vm-event: ~s\n" e)
+ (typecase e
+ (<exception-event>
+ ;;(log "exception: ~s\n" (! exception e))
+ ;;(log "exception-message: ~s\n"
+ ;; (exception-message (vm-demirror *the-vm* (! exception e))))
+ ;;(log "exception-location: ~s\n" (src-loc>str (! location e)))
+ ;;(log "exception-catch-location: ~s\n" (src-loc>str (! catch-location e)))
+ (cond ((! notifyUncaught (as <com.sun.jdi.request.ExceptionRequest>
+ (! request e)))
+ (process-exception e c state))
+ (#t
+ (let* ((t (! thread e))
+ (r (! request e))
+ (ex (! exception e)))
+ (unless (eq? *last-exception* ex)
+ (set *last-exception* ex)
+ (set *last-stacktrace* (copy-stack t)))
+ (! resume t))
+ state)))
+ (<step-event>
+ (let* ((r (! request e))
+ (k (! get-property r 'continuation)))
+ (! disable r)
+ (log "k: ~s\n" k)
+ (k e))
+ state)
+ (<breakpoint-event>
+ (log "breakpoint event: ~a\n" e)
+ (debug-thread (! thread e) e state c))
+ ))
+
+(df process-exception ((e <exception-event>) (c <chan>) state)
+ (let* ((tref (! thread e))
+ (tid (! uniqueID tref))
+ (s (get state tid #f)))
+ (mcase s
+ ('#f
+ ;; XXX redundant in debug-thread
+ (let* ((level 1)
+ (state (put state tid (list tref level (list e)))))
+ (send c `(forward (:debug ,tid ,level
+ ,@(debug-info tid 0 15 state))))
+ (send c `(forward (:debug-activate ,tid ,level)))
+ state))
+ ((_ level exs)
+ (send c `(forward (:debug-activate ,(! uniqueID tref) ,level)))
+ (put state tid (list tref (1+ level) (cons e exs)))))))
+
+(define-simple-class <faked-frame> ()
+ (loc :: <location>)
+ (args)
+ (names)
+ (values :: <java.util.Map>)
+ (self)
+ ((*init* (loc :: <location>) args names (values :: <java.util.Map>) self)
+ (set (@ loc (this)) loc)
+ (set (@ args (this)) args)
+ (set (@ names (this)) names)
+ (set (@ values (this)) values)
+ (set (@ self (this)) self))
+ ((toString) :: <str>
+ (format "#<ff ~a>" (src-loc>str loc))))
+
+(df copy-stack ((t <thread-ref>))
+ (packing (pack)
+ (iter (! frames t)
+ (fun ((f <frame>))
+ (let ((vars (ignore-errors (! visibleVariables f))))
+ (pack (<faked-frame>
+ (or (ignore-errors (! location f)) #!null)
+ (ignore-errors (! getArgumentValues f))
+ (or vars #!null)
+ (or (and vars (ignore-errors (! get-values f vars)))
+ #!null)
+ (ignore-errors (! thisObject f)))))))))
+
+(define-simple-class <interrupt-event> (<event>)
+ (thread :: <thread-ref>)
+ ((*init* (thread :: <thread-ref>)) (set (@ thread (this)) thread))
+ ((request) :: <com.sun.jdi.request.EventRequest> #!null)
+ ((virtualMachine) :: <vm> (! virtualMachine thread)))
+
+(df break (#!optional condition)
+ ((breakpoint condition)))
+
+;; We set a breakpoint on this function. It returns a function which
+;; specifies what the debuggee should do next (the actual return value
+;; is set via JDI). Lets hope that the compiler doesn't optimize this
+;; away.
+(df breakpoint (condition => <function>)
+ (fun () #!null))
+
+;; Enable breakpoints event on the breakpoint function.
+(df request-breakpoint ((vm <vm>))
+ (let* ((swank-classes (! classesByName vm "swank-kawa"))
+ (swank-classes-legacy (! classesByName vm "swank$Mnkawa"))
+ (class :: <class-type> (1st (if (= (length swank-classes) 0)
+ swank-classes-legacy
+ swank-classes)))
+ (meth :: <meth-ref> (1st (! methodsByName class "breakpoint")))
+ (erm (! eventRequestManager vm))
+ (req (! createBreakpointRequest erm (! location meth))))
+ (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req))
+ (! put-property req 'swank #t)
+ (! put-property req 'argname "condition")
+ (! enable req)))
+
+(df log-vm-props ((vm <vm>))
+ (letrec-syntax ((p (syntax-rules ()
+ ((p name) (log "~s: ~s\n" 'name (! name vm)))))
+ (p* (syntax-rules ()
+ ((p* n ...) (seq (p n) ...)))))
+ (p* canBeModified
+ canRedefineClasses
+ canAddMethod
+ canUnrestrictedlyRedefineClasses
+ canGetBytecodes
+ canGetConstantPool
+ canGetSyntheticAttribute
+ canGetSourceDebugExtension
+ canPopFrames
+ canForceEarlyReturn
+ canGetMethodReturnValues
+ canGetInstanceInfo
+ )))
+
+;;;;; Debugger
+
+(df debug-thread ((tref <thread-ref>) (ev <event>) state (c <chan>))
+ (unless (! is-suspended tref)
+ (! suspend tref))
+ (let* ((id (! uniqueID tref))
+ (level 1)
+ (state (put state id (list tref level (list ev)))))
+ (send c `(forward (:debug ,id ,level ,@(debug-info id 0 10 state))))
+ (send c `(forward (:debug-activate ,id ,level)))
+ state))
+
+(df interrupt-thread ((tref <thread-ref>) state (c <chan>))
+ (debug-thread tref (<interrupt-event> tref) state c))
+
+(df debug-info ((tid <int>) (from <int>) to state)
+ (mlet ((thread-ref level evs) (get state tid #f))
+ (let* ((tref (as <thread-ref> thread-ref))
+ (vm (! virtualMachine tref))
+ (ev (as <event> (car evs)))
+ (ex (typecase ev
+ (<breakpoint-event> (breakpoint-condition ev))
+ (<exception-event> (! exception ev))
+ (<interrupt-event> (<java.lang.Exception> "Interrupt"))))
+ (desc (typecase ex
+ (<obj-ref>
+ ;;(log "ex: ~a ~a\n" ex (vm-demirror vm ex))
+ (! toString (vm-demirror vm ex)))
+ (<java.lang.Throwable> (! toString ex))))
+ (type (format " [type ~a]"
+ (typecase ex
+ (<obj-ref> (! name (! referenceType ex)))
+ (<object> (!! getName getClass ex)))))
+ (bt (thread-frames tid from to state)))
+ `((,desc ,type nil) (("quit" "terminate current thread")) ,bt ()))))
+
+(df breakpoint-condition ((e <breakpoint-event>) => <obj-ref>)
+ (let ((frame (! frame (! thread e) 0)))
+ (1st (! get-argument-values frame))))
+
+(df thread-frames ((tid <int>) (from <int>) to state)
+ (mlet ((thread level evs) (get state tid #f))
+ (let* ((thread (as <thread-ref> thread))
+ (fcount (! frameCount thread))
+ (stacktrace (event-stacktrace (car evs)))
+ (missing (cond ((zero? (len stacktrace)) 0)
+ (#t (- (len stacktrace) fcount))))
+ (fstart (max (- from missing) 0))
+ (flen (max (- to from missing) 0))
+ (frames (! frames thread fstart (min flen (- fcount fstart)))))
+ (packing (pack)
+ (let ((i from))
+ (dotimes (_ (max (- missing from) 0))
+ (pack (list i (format "~a" (stacktrace i))))
+ (set i (1+ i)))
+ (iter frames (fun ((f <frame>))
+ (let ((s (frame-to-string f)))
+ (pack (list i s))
+ (set i (1+ i))))))))))
+
+(df event-stacktrace ((ev <event>))
+ (let ((nothing (fun () (<java.lang.StackTraceElement[]>)))
+ (vm (! virtualMachine ev)))
+ (typecase ev
+ (<breakpoint-event>
+ (let ((condition (vm-demirror vm (breakpoint-condition ev))))
+ (cond ((instance? condition <throwable>)
+ (throwable-stacktrace vm condition))
+ (#t (nothing)))))
+ (<exception-event>
+ (throwable-stacktrace vm (vm-demirror vm (! exception ev))))
+ (<event> (nothing)))))
+
+(df throwable-stacktrace ((vm <vm>) (ex <throwable>))
+ (cond ((== ex (ignore-errors (vm-demirror vm *last-exception*)))
+ *last-stacktrace*)
+ (#t
+ (! getStackTrace ex))))
+
+(df frame-to-string ((f <frame>))
+ (let ((loc (! location f))
+ (vm (! virtualMachine f)))
+ (format "~a (~a)" (!! name method loc)
+ (call-with-abort
+ (fun () (format "~{~a~^ ~}"
+ (mapi (! getArgumentValues f)
+ (fun (arg)
+ (pprint-to-string
+ (vm-demirror vm arg))))))))))
+
+(df frame-src-loc ((tid <int>) (n <int>) state)
+ (try-catch
+ (mlet* (((frame vm) (nth-frame tid n state))
+ (vm (as <vm> vm)))
+ (src-loc>elisp
+ (typecase frame
+ (<frame> (! location frame))
+ (<faked-frame> (@ loc frame))
+ (<java.lang.StackTraceElement>
+ (let* ((classname (! getClassName frame))
+ (classes (! classesByName vm classname))
+ (t (as <ref-type> (1st classes))))
+ (1st (! locationsOfLine t (! getLineNumber frame))))))))
+ (ex <throwable>
+ (let ((msg (! getMessage ex)))
+ `(:error ,(if (== msg #!null)
+ (! toString ex)
+ msg))))))
+
+(df nth-frame ((tid <int>) (n <int>) state)
+ (mlet ((tref level evs) (get state tid #f))
+ (let* ((thread (as <thread-ref> tref))
+ (fcount (! frameCount thread))
+ (stacktrace (event-stacktrace (car evs)))
+ (missing (cond ((zero? (len stacktrace)) 0)
+ (#t (- (len stacktrace) fcount))))
+ (vm (! virtualMachine thread))
+ (frame (cond ((< n missing)
+ (stacktrace n))
+ (#t (! frame thread (- n missing))))))
+ (list frame vm))))
+
+;;;;; Locals
+
+(df frame-locals ((tid <int>) (n <int>) state)
+ (mlet ((thread _ _) (get state tid #f))
+ (let* ((thread (as <thread-ref> thread))
+ (vm (! virtualMachine thread))
+ (p (fun (x) (pprint-to-string
+ (call-with-abort (fun () (vm-demirror vm x)))))))
+ (map (fun (x)
+ (mlet ((name value) x)
+ (list ':name name ':value (p value) ':id 0)))
+ (%frame-locals tid n state)))))
+
+(df frame-local-var ((tid <int>) (frame <int>) (var <int>) state => <mirror>)
+ (cadr (nth (%frame-locals tid frame state) var)))
+
+(df %frame-locals ((tid <int>) (n <int>) state)
+ (mlet ((frame _) (nth-frame tid n state))
+ (typecase frame
+ (<frame>
+ (let* ((visible (try-catch (! visibleVariables frame)
+ (ex <com.sun.jdi.AbsentInformationException>
+ '())))
+ (map (! getValues frame visible))
+ (p (fun (x) x)))
+ (packing (pack)
+ (let ((self (ignore-errors (! thisObject frame))))
+ (when self
+ (pack (list "this" (p self)))))
+ (iter (! entrySet map)
+ (fun ((e <java.util.Map$Entry>))
+ (let ((var (as <local-var> (! getKey e)))
+ (val (as <value> (! getValue e))))
+ (pack (list (! name var) (p val)))))))))
+ (<faked-frame>
+ (packing (pack)
+ (when (@ self frame)
+ (pack (list "this" (@ self frame))))
+ (iter (! entrySet (@ values frame))
+ (fun ((e <java.util.Map$Entry>))
+ (let ((var (as <local-var> (! getKey e)))
+ (val (as <value> (! getValue e))))
+ (pack (list (! name var) val)))))))
+ (<java.lang.StackTraceElement> '()))))
+
+(df disassemble-frame ((tid <int>) (frame <int>) state)
+ (mlet ((frame _) (nth-frame tid frame state))
+ (typecase frame
+ (<java.lang.StackTraceElement> "<??>")
+ (<frame>
+ (let* ((l (! location frame))
+ (m (! method l))
+ (c (! declaringType l)))
+ (disassemble-to-string m))))))
+
+;;;;; Restarts
+
+;; FIXME: factorize
+(df throw-to-toplevel ((tid <int>) (id <int>) (c <chan>) state)
+ (mlet ((tref level exc) (get state tid #f))
+ (let* ((t (as <thread-ref> tref))
+ (ev (car exc)))
+ (typecase ev
+ (<exception-event> ; actually uncaughtException
+ (! resume t)
+ (reply-abort c id)
+ ;;(send-debug-return c tid state)
+ (do ((level level (1- level))
+ (exc exc (cdr exc)))
+ ((null? exc))
+ (send c `(forward (:debug-return ,tid ,level nil))))
+ (del state tid))
+ (<breakpoint-event>
+ ;; XXX race condition?
+ (log "resume from from break (suspendCount: ~d)\n" (! suspendCount t))
+ (let ((vm (! virtualMachine t))
+ (k (fun () (primitive-throw (<listener-abort>)))))
+ (reply-abort c id)
+ (! force-early-return t (vm-mirror vm k))
+ (! resume t)
+ (do ((level level (1- level))
+ (exc exc (cdr exc)))
+ ((null? exc))
+ (send c `(forward (:debug-return ,tid ,level nil))))
+ (del state tid)))
+ (<interrupt-event>
+ (log "resume from from interrupt\n")
+ (let ((vm (! virtualMachine t)))
+ (! stop t (vm-mirror vm (<listener-abort>)))
+ (! resume t)
+ (reply-abort c id)
+ (do ((level level (1- level))
+ (exc exc (cdr exc)))
+ ((null? exc))
+ (send c `(forward (:debug-return ,tid ,level nil))))
+ (del state tid))
+ )))))
+
+(df thread-continue ((tid <int>) (id <int>) (c <chan>) state)
+ (mlet ((tref level exc) (get state tid #f))
+ (log "thread-continue: ~a ~a ~a \n" tref level exc)
+ (let* ((t (as <thread-ref> tref)))
+ (! resume t))
+ (reply-abort c id)
+ (do ((level level (1- level))
+ (exc exc (cdr exc)))
+ ((null? exc))
+ (send c `(forward (:debug-return ,tid ,level nil))))
+ (del state tid)))
+
+(df thread-step ((t <thread-ref>) k)
+ (let* ((vm (! virtual-machine t))
+ (erm (! eventRequestManager vm))
+ (<sr> <com.sun.jdi.request.StepRequest>)
+ (req (! createStepRequest erm t
+ (@s <sr> STEP_MIN)
+ (@s <sr> STEP_OVER))))
+ (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req))
+ (! addCountFilter req 1)
+ (! put-property req 'continuation k)
+ (! enable req)))
+
+(df eval-in-thread ((t <thread-ref>) sexp
+ #!optional (env :: <env> (!s <env> current)))
+ (let* ((vm (! virtualMachine t))
+ (sc :: <class-type>
+ (1st (! classes-by-name vm "kawa.standard.Scheme")))
+ (ev :: <meth-ref>
+ (1st (! methods-by-name sc "eval"
+ (cat "(Ljava/lang/Object;Lgnu/mapping/Environment;)"
+ "Ljava/lang/Object;")))))
+ (! invokeMethod sc t ev (list sexp env)
+ (@s <class-type> INVOKE_SINGLE_THREADED))))
+
+;;;;; Threads
+
+(df list-threads (vm :: <vm> state)
+ (let* ((threads (! allThreads vm)))
+ (put state 'all-threads threads)
+ (packing (pack)
+ (pack '(\:id \:name \:status \:priority))
+ (iter threads (fun ((t <thread-ref>))
+ (pack (list (! uniqueID t)
+ (! name t)
+ (let ((s (thread-status t)))
+ (if (! is-suspended t)
+ (cat "SUSPENDED/" s)
+ s))
+ 0)))))))
+
+(df thread-status (t :: <thread-ref>)
+ (let ((s (! status t)))
+ (cond ((= s (@s <thread-ref> THREAD_STATUS_UNKNOWN)) "UNKNOWN")
+ ((= s (@s <thread-ref> THREAD_STATUS_ZOMBIE)) "ZOMBIE")
+ ((= s (@s <thread-ref> THREAD_STATUS_RUNNING)) "RUNNING")
+ ((= s (@s <thread-ref> THREAD_STATUS_SLEEPING)) "SLEEPING")
+ ((= s (@s <thread-ref> THREAD_STATUS_MONITOR)) "MONITOR")
+ ((= s (@s <thread-ref> THREAD_STATUS_WAIT)) "WAIT")
+ ((= s (@s <thread-ref> THREAD_STATUS_NOT_STARTED)) "NOT_STARTED")
+ (#t "<bug>"))))
+
+;;;;; Bootstrap
+
+(df vm-attach (=> <vm>)
+ (attach (getpid) 20))
+
+(df attach (pid timeout)
+ (log "attaching: ~a ~a\n" pid timeout)
+ (let* ((<ac> <com.sun.jdi.connect.AttachingConnector>)
+ (<arg> <com.sun.jdi.connect.Connector$Argument>)
+ (vmm (!s com.sun.jdi.Bootstrap virtualMachineManager))
+ (pa (as <ac>
+ (or
+ (find-if (! attaching-connectors vmm)
+ (fun (x :: <ac>)
+ (! equals (! name x) "com.sun.jdi.ProcessAttach"))
+ #f)
+ (error "ProcessAttach connector not found"))))
+ (args (! default-arguments pa)))
+ (! set-value (as <arg> (! get args (to-str "pid"))) pid)
+ (when timeout
+ (! set-value (as <arg> (! get args (to-str "timeout"))) timeout))
+ (log "attaching2: ~a ~a\n" pa args)
+ (! attach pa args)))
+
+(df getpid ()
+ (let ((p (make-process (command-parse "echo $PPID") #!null)))
+ (! waitFor p)
+ (! read-line (<java.io.BufferedReader> (<in> (! get-input-stream p))))))
+
+(df request-uncaught-exception-events ((vm <vm>))
+ (let* ((erm (! eventRequestManager vm))
+ (req (! createExceptionRequest erm #!null #f #t)))
+ (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req))
+ (! addThreadFilter req (vm-mirror vm (current-thread)))
+ (! enable req)))
+
+
+(df request-caught-exception-events ((vm <vm>))
+ (let* ((erm (! eventRequestManager vm))
+ (req (! createExceptionRequest erm #!null #t #f)))
+ (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req))
+ (! addThreadFilter req (vm-mirror vm (current-thread)))
+ (! addClassExclusionFilter req "java.lang.ClassLoader")
+ (! addClassExclusionFilter req "java.net.URLClassLoader")
+ (! addClassExclusionFilter req "java.net.URLClassLoader$1")
+ (! enable req)))
+
+(df set-stacktrace-recording ((vm <vm>) (flag <boolean>))
+ (for (((e :: <com.sun.jdi.request.ExceptionRequest>)
+ (!! exceptionRequests eventRequestManager vm)))
+ (when (! notify-caught e)
+ (! setEnabled e flag))))
+
+;; (set-stacktrace-recording *the-vm* #f)
+
+(df vm-to-string ((vm <vm>))
+ (let* ((obj (as <ref-type> (1st (! classesByName vm "java.lang.Object"))))
+ (met (as <meth-ref> (1st (! methodsByName obj "toString")))))
+ (fun ((o <obj-ref>) (t <thread-ref>))
+ (! value
+ (as <str-ref>
+ (! invokeMethod o t met '()
+ (@s <obj-ref> INVOKE_SINGLE_THREADED)))))))
+
+(define-simple-class <swank-global-variable> ()
+ (var #:allocation 'static))
+
+(define-variable *global-get-mirror* #!null)
+(define-variable *global-set-mirror* #!null)
+(define-variable *global-get-raw* #!null)
+(define-variable *global-set-raw* #!null)
+
+(df init-global-field ((vm <vm>))
+ (when (nul? *global-get-mirror*)
+ (set (@s <swank-global-variable> var) #!null) ; prepare class
+ (let* ((swank-global-variable-classes
+ (! classes-by-name vm "swank-global-variable"))
+ (swank-global-variable-classes-legacy
+ (! classes-by-name vm "swank$Mnglobal$Mnvariable"))
+ (c (as <com.sun.jdi.ClassType>
+ (1st (if (= (length swank-global-variable-classes) 0)
+ swank-global-variable-classes-legacy
+ swank-global-variable-classes))))
+ (f (! fieldByName c "var")))
+ (set *global-get-mirror* (fun () (! getValue c f)))
+ (set *global-set-mirror* (fun ((v <obj-ref>)) (! setValue c f v))))
+ (set *global-get-raw* (fun () '() (@s <swank-global-variable> var)))
+ (set *global-set-raw* (fun (x)
+ (set (@s <swank-global-variable> var) x)))))
+
+(df vm-mirror ((vm <vm>) obj)
+ (synchronized vm
+ (init-global-field vm)
+ (*global-set-raw* obj)
+ (*global-get-mirror*)))
+
+(df vm-demirror ((vm <vm>) (v <value>))
+ (synchronized vm
+ (if (== v #!null)
+ #!null
+ (typecase v
+ (<obj-ref> (init-global-field vm)
+ (*global-set-mirror* v)
+ (*global-get-raw*))
+ (<com.sun.jdi.IntegerValue> (! value v))
+ (<com.sun.jdi.LongValue> (! value v))
+ (<com.sun.jdi.CharValue> (! value v))
+ (<com.sun.jdi.ByteValue> (! value v))
+ (<com.sun.jdi.BooleanValue> (! value v))
+ (<com.sun.jdi.ShortValue> (! value v))
+ (<com.sun.jdi.FloatValue> (! value v))
+ (<com.sun.jdi.DoubleValue> (! value v))))))
+
+(df vm-set-slot ((vm <vm>) (o <object>) (name <str>) value)
+ (let* ((o (as <obj-ref> (vm-mirror vm o)))
+ (t (! reference-type o))
+ (f (! field-by-name t name)))
+ (! set-value o f (vm-mirror vm value))))
+
+(define-simple-class <ucex-handler>
+ (<java.lang.Thread$UncaughtExceptionHandler>)
+ (f :: <gnu.mapping.Procedure>)
+ ((*init* (f :: <gnu.mapping.Procedure>)) (set (@ f (this)) f))
+ ((uncaughtException (t :: <thread>) (e :: <throwable>))
+ :: <void>
+ (! println (@s java.lang.System err) (to-str "uhexc:::"))
+ (! apply2 f t e)
+ #!void))
+
+;;;; Channels
+
+(df spawn (f)
+ (let ((thread (<thread> (%%runnable f))))
+ (! start thread)
+ thread))
+
+
+;; gnu.mapping.RunnableClosure uses the try{...}catch(Throwable){...}
+;; idiom which defeats all attempts to use a break-on-error-style
+;; debugger. Previously I had my own version of RunnableClosure
+;; without that deficiency but something in upstream changed and it no
+;; longer worked. Now we use the normal RunnableClosure and at the
+;; cost of taking stack snapshots on every throw.
+(df %%runnable (f => <java.lang.Runnable>)
+ ;;(<runnable> f)
+ ;;(<gnu.mapping.RunnableClosure> f)
+ ;;(runnable f)
+ (%runnable f)
+ )
+
+(df %runnable (f => <java.lang.Runnable>)
+ (runnable
+ (fun ()
+ (try-catch (f)
+ (ex <throwable>
+ (log "exception in thread ~s: ~s" (current-thread)
+ ex)
+ (! printStackTrace ex))))))
+
+(df chan ()
+ (let ((lock (<object>))
+ (im (<chan>))
+ (ex (<chan>)))
+ (set (@ lock im) lock)
+ (set (@ lock ex) lock)
+ (set (@ peer im) ex)
+ (set (@ peer ex) im)
+ (cons im ex)))
+
+(df immutable? (obj)
+ (or (== obj #!null)
+ (symbol? obj)
+ (number? obj)
+ (char? obj)
+ (instance? obj <str>)
+ (null? obj)))
+
+(df send ((c <chan>) value => <void>)
+ (df pass (obj)
+ (cond ((immutable? obj) obj)
+ ((string? obj) (! to-string obj))
+ ((pair? obj)
+ (let loop ((r (list (pass (car obj))))
+ (o (cdr obj)))
+ (cond ((null? o) (reverse! r))
+ ((pair? o) (loop (cons (pass (car o)) r) (cdr o)))
+ (#t (append (reverse! r) (pass o))))))
+ ((instance? obj <chan>)
+ (let ((o :: <chan> obj))
+ (assert (== (@ owner o) (current-thread)))
+ (synchronized (@ lock c)
+ (set (@ owner o) (@ owner (@ peer c))))
+ o))
+ ((or (instance? obj <env>)
+ (instance? obj <mirror>))
+ ;; those can be shared, for pragmatic reasons
+ obj
+ )
+ (#t (error "can't send" obj (class-name-sans-package obj)))))
+ ;;(log "send: ~s ~s -> ~s\n" value (@ owner c) (@ owner (@ peer c)))
+ (assert (== (@ owner c) (current-thread)))
+ ;;(log "lock: ~s send\n" (@ owner (@ peer c)))
+ (synchronized (@ owner (@ peer c))
+ (! put (@ queue (@ peer c)) (pass value))
+ (! notify (@ owner (@ peer c))))
+ ;;(log "unlock: ~s send\n" (@ owner (@ peer c)))
+ )
+
+(df recv ((c <chan>))
+ (cdr (recv/timeout (list c) 0)))
+
+(df recv* ((cs <iterable>))
+ (recv/timeout cs 0))
+
+(df recv/timeout ((cs <iterable>) (timeout <long>))
+ (let ((self (current-thread))
+ (end (if (zero? timeout)
+ 0
+ (+ (current-time) timeout))))
+ ;;(log "lock: ~s recv\n" self)
+ (synchronized self
+ (let loop ()
+ ;;(log "receive-loop: ~s\n" self)
+ (let ((ready (find-if cs
+ (fun ((c <chan>))
+ (not (! is-empty (@ queue c))))
+ #f)))
+ (cond (ready
+ ;;(log "unlock: ~s recv\n" self)
+ (cons ready (! take (@ queue (as <chan> ready)))))
+ ((zero? timeout)
+ ;;(log "wait: ~s recv\n" self)
+ (! wait self) (loop))
+ (#t
+ (let ((now (current-time)))
+ (cond ((<= end now)
+ 'timeout)
+ (#t
+ ;;(log "wait: ~s recv\n" self)
+ (! wait self (- end now))
+ (loop)))))))))))
+
+(df rpc ((c <chan>) msg)
+ (mlet* (((im . ex) (chan))
+ ((op . args) msg))
+ (send c `(,op ,ex . ,args))
+ (recv im)))
+
+(df spawn/chan (f)
+ (mlet ((im . ex) (chan))
+ (let ((thread (<thread> (%%runnable (fun () (f ex))))))
+ (set (@ owner ex) thread)
+ (! start thread)
+ (cons im thread))))
+
+(df spawn/chan/catch (f)
+ (spawn/chan
+ (fun (c)
+ (try-catch
+ (f c)
+ (ex <throwable>
+ (send c `(error ,(! toString ex)
+ ,(class-name-sans-package ex)
+ ,(map (fun (e) (! to-string e))
+ (array-to-list (! get-stack-trace ex))))))))))
+
+;;;; Logging
+
+(define swank-log-port (current-error-port))
+(df log (fstr #!rest args)
+ (synchronized swank-log-port
+ (apply format swank-log-port fstr args)
+ (force-output swank-log-port))
+ #!void)
+
+;;;; Random helpers
+
+(df 1+ (x) (+ x 1))
+(df 1- (x) (- x 1))
+
+(df len (x => <int>)
+ (typecase x
+ (<list> (length x))
+ (<str> (! length x))
+ (<string> (string-length x))
+ (<vector> (vector-length x))
+ (<java.util.List> (! size x))
+ (<object[]> (@ length x))))
+
+;;(df put (tab key value) (hash-table-set! tab key value) tab)
+;;(df get (tab key default) (hash-table-ref/default tab key default))
+;;(df del (tab key) (hash-table-delete! tab key) tab)
+;;(df tab () (make-hash-table))
+
+(df put (tab key value) (hashtable-set! tab key value) tab)
+(df get (tab key default) (hashtable-ref tab key default))
+(df del (tab key) (hashtable-delete! tab key) tab)
+(df tab () (make-eqv-hashtable))
+
+(df equal (x y => <boolean>) (equal? x y))
+
+(df current-thread (=> <thread>) (!s java.lang.Thread currentThread))
+(df current-time (=> <long>) (!s java.lang.System currentTimeMillis))
+
+(df nul? (x) (== x #!null))
+
+(df read-from-string (str)
+ (call-with-input-string str read))
+
+;;(df print-to-string (obj) (call-with-output-string (fun (p) (write obj p))))
+
+(df pprint-to-string (obj)
+ (let* ((w (<java.io.StringWriter>))
+ (p (<out-port> w #t #f)))
+ (try-catch (print-object obj p)
+ (ex <throwable>
+ (format p "#<error while printing ~a ~a>"
+ ex (class-name-sans-package ex))))
+ (! flush p)
+ (to-string (! getBuffer w))))
+
+(df print-object (obj stream)
+ (typecase obj
+ #;
+ ((or (eql #!null) (eql #!eof)
+ <list> <number> <character> <string> <vector> <procedure> <boolean>)
+ (write obj stream))
+ (#t
+ #;(print-unreadable-object obj stream)
+ (write obj stream)
+ )))
+
+(df print-unreadable-object ((o <object>) stream)
+ (let* ((string (! to-string o))
+ (class (! get-class o))
+ (name (! get-name class))
+ (simplename (! get-simple-name class)))
+ (cond ((! starts-with string "#<")
+ (format stream "~a" string))
+ ((or (! starts-with string name)
+ (! starts-with string simplename))
+ (format stream "#<~a>" string))
+ (#t
+ (format stream "#<~a ~a>" name string)))))
+
+(define cat string-append)
+
+(df values-to-list (values)
+ (typecase values
+ (<gnu.mapping.Values> (array-to-list (! getValues values)))
+ (<object> (list values))))
+
+;; (to-list (as-list (values 1 2 2)))
+
+(df array-to-list ((array <object[]>) => <list>)
+ (packing (pack)
+ (dotimes (i (@ length array))
+ (pack (array i)))))
+
+(df lisp-bool (obj)
+ (cond ((== obj 'nil) #f)
+ ((== obj 't) #t)
+ (#t (error "Can't map lisp boolean" obj))))
+
+(df path-sans-extension ((p path) => <string>)
+ (let ((ex (! get-extension p))
+ (str (! to-string p)))
+ (to-string (cond ((not ex) str)
+ (#t (! substring str 0 (- (len str) (len ex) 1)))))))
+
+(df class-name-sans-package ((obj <object>))
+ (cond ((nul? obj) "<#!null>")
+ (#t
+ (try-catch
+ (let* ((c (! get-class obj))
+ (n (! get-simple-name c)))
+ (cond ((equal n "") (! get-name c))
+ (#t n)))
+ (e <java.lang.Throwable>
+ (format "#<~a: ~a>" e (! get-message e)))))))
+
+(df list-env (#!optional (env :: <env> (!s <env> current)))
+ (let ((enum (! enumerateAllLocations env)))
+ (packing (pack)
+ (while (! hasMoreElements enum)
+ (pack (! nextLocation enum))))))
+
+(df list-file (filename)
+ (with (port (call-with-input-file filename))
+ (let* ((lang (!s gnu.expr.Language getDefaultLanguage))
+ (messages (<gnu.text.SourceMessages>))
+ (comp (! parse lang (as <in-port> port) messages 0)))
+ (! get-module comp))))
+
+(df list-decls (file)
+ (let* ((module (as <gnu.expr.ModuleExp> (list-file file))))
+ (do ((decl :: <gnu.expr.Declaration>
+ (! firstDecl module) (! nextDecl decl)))
+ ((nul? decl))
+ (format #t "~a ~a:~d:~d\n" decl
+ (! getFileName decl)
+ (! getLineNumber decl)
+ (! getColumnNumber decl)
+ ))))
+
+(df %time (f)
+ (define-alias <mf> <java.lang.management.ManagementFactory>)
+ (define-alias <gc> <java.lang.management.GarbageCollectorMXBean>)
+ (let* ((gcs (!s <mf> getGarbageCollectorMXBeans))
+ (mem (!s <mf> getMemoryMXBean))
+ (jit (!s <mf> getCompilationMXBean))
+ (oldjit (! getTotalCompilationTime jit))
+ (oldgc (packing (pack)
+ (iter gcs (fun ((gc <gc>))
+ (pack (cons gc
+ (list (! getCollectionCount gc)
+ (! getCollectionTime gc))))))))
+ (heap (!! getUsed getHeapMemoryUsage mem))
+ (nonheap (!! getUsed getNonHeapMemoryUsage mem))
+ (start (!s java.lang.System nanoTime))
+ (values (f))
+ (end (!s java.lang.System nanoTime))
+ (newheap (!! getUsed getHeapMemoryUsage mem))
+ (newnonheap (!! getUsed getNonHeapMemoryUsage mem)))
+ (format #t "~&")
+ (let ((njit (! getTotalCompilationTime jit)))
+ (format #t "; JIT compilation: ~:d ms (~:d)\n" (- njit oldjit) njit))
+ (iter gcs (fun ((gc <gc>))
+ (mlet ((_ count time) (assoc gc oldgc))
+ (format #t "; GC ~a: ~:d ms (~d)\n"
+ (! getName gc)
+ (- (! getCollectionTime gc) time)
+ (- (! getCollectionCount gc) count)))))
+ (format #t "; Heap: ~@:d (~:d)\n" (- newheap heap) newheap)
+ (format #t "; Non-Heap: ~@:d (~:d)\n" (- newnonheap nonheap) newnonheap)
+ (format #t "; Elapsed time: ~:d us\n" (/ (- end start) 1000))
+ values))
+
+(define-syntax time
+ (syntax-rules ()
+ ((time form)
+ (%time (lambda () form)))))
+
+(df gc ()
+ (let* ((mem (!s java.lang.management.ManagementFactory getMemoryMXBean))
+ (oheap (!! getUsed getHeapMemoryUsage mem))
+ (onheap (!! getUsed getNonHeapMemoryUsage mem))
+ (_ (! gc mem))
+ (heap (!! getUsed getHeapMemoryUsage mem))
+ (nheap (!! getUsed getNonHeapMemoryUsage mem)))
+ (format #t "; heap: ~@:d (~:d) non-heap: ~@:d (~:d)\n"
+ (- heap oheap) heap (- onheap nheap) nheap)))
+
+(df room ()
+ (let* ((pools (!s java.lang.management.ManagementFactory
+ getMemoryPoolMXBeans))
+ (mem (!s java.lang.management.ManagementFactory getMemoryMXBean))
+ (heap (!! getUsed getHeapMemoryUsage mem))
+ (nheap (!! getUsed getNonHeapMemoryUsage mem)))
+ (iter pools (fun ((p <java.lang.management.MemoryPoolMXBean>))
+ (format #t "~&; ~a~1,16t: ~10:d\n"
+ (! getName p)
+ (!! getUsed getUsage p))))
+ (format #t "; Heap~1,16t: ~10:d\n" heap)
+ (format #t "; Non-Heap~1,16t: ~10:d\n" nheap)))
+
+;; (df javap (class #!key method signature)
+;; (let* ((<is> <java.io.ByteArrayInputStream>)
+;; (bytes
+;; (typecase class
+;; (<string> (read-bytes (<java.io.FileInputStream> (to-str class))))
+;; (<byte[]> class)
+;; (<symbol> (read-class-file class))))
+;; (cdata (<sun.tools.javap.ClassData> (<is> bytes)))
+;; (p (<sun.tools.javap.JavapPrinter>
+;; (<is> bytes)
+;; (current-output-port)
+;; (<sun.tools.javap.JavapEnvironment>))))
+;; (cond (method
+;; (dolist ((m <sun.tools.javap.MethodData>)
+;; (array-to-list (! getMethods cdata)))
+;; (when (and (equal (to-str method) (! getName m))
+;; (or (not signature)
+;; (equal signature (! getInternalSig m))))
+;; (! printMethodSignature p m (! getAccess m))
+;; (! printExceptions p m)
+;; (newline)
+;; (! printVerboseHeader p m)
+;; (! printcodeSequence p m))))
+;; (#t (p:print)))
+;; (values)))
+
+(df read-bytes ((is <java.io.InputStream>) => <byte[]>)
+ (let ((os (<java.io.ByteArrayOutputStream>)))
+ (let loop ()
+ (let ((c (! read is)))
+ (cond ((= c -1))
+ (#t (! write os c) (loop)))))
+ (! to-byte-array os)))
+
+(df read-class-file ((name <symbol>) => <byte[]>)
+ (let ((f (cat (! replace (to-str name) (as <char> #\.) (as <char> #\/))
+ ".class")))
+ (mcase (find-file-in-path f (class-path))
+ ('#f (ferror "Can't find classfile for ~s" name))
+ ((:zip zipfile entry)
+ (let* ((z (<java.util.zip.ZipFile> (as <str> zipfile)))
+ (e (! getEntry z (as <str> entry))))
+ (read-bytes (! getInputStream z e))))
+ ((:file s) (read-bytes (<java.io.FileInputStream> (as <str> s)))))))
+
+(df all-instances ((vm <vm>) (classname <str>))
+ (mappend (fun ((c <class-type>)) (to-list (! instances c (as long 9999))))
+ (%all-subclasses vm classname)))
+
+(df %all-subclasses ((vm <vm>) (classname <str>))
+ (mappend (fun ((c <class-type>)) (cons c (to-list (! subclasses c))))
+ (to-list (! classes-by-name vm classname))))
+
+(df with-output-to-string (thunk => <str>)
+ (call-with-output-string
+ (fun (s) (parameterize ((current-output-port s)) (thunk)))))
+
+(df find-if ((i <iterable>) test default)
+ (let ((iter (! iterator i))
+ (found #f))
+ (while (and (not found) (! has-next iter))
+ (let ((e (! next iter)))
+ (when (test e)
+ (set found #t)
+ (set default e))))
+ default))
+
+(df filter ((i <iterable>) test => <list>)
+ (packing (pack)
+ (for ((e i))
+ (when (test e)
+ (pack e)))))
+
+(df iter ((i <iterable>) f)
+ (for ((e i)) (f e)))
+
+(df mapi ((i <iterable>) f => <list>)
+ (packing (pack) (for ((e i)) (pack (f e)))))
+
+(df nth ((i <iterable>) (n <int>))
+ (let ((iter (! iterator i)))
+ (dotimes (i n)
+ (! next iter))
+ (! next iter)))
+
+(df 1st ((i <iterable>)) (!! next iterator i))
+
+(df to-list ((i <iterable>) => <list>)
+ (packing (pack) (for ((e i)) (pack e))))
+
+(df as-list ((o <java.lang.Object[]>) => <java.util.List>)
+ (!s java.util.Arrays asList o))
+
+(df mappend (f list)
+ (apply append (map f list)))
+
+(df subseq (s from to)
+ (typecase s
+ (<list> (apply list (! sub-list s from to)))
+ (<vector> (apply vector (! sub-list s from to)))
+ (<str> (! substring s from to))
+ (<byte[]> (let* ((len (as <int> (- to from)))
+ (t (<byte[]> #:length len)))
+ (!s java.lang.System arraycopy s from t 0 len)
+ t))))
+
+(df to-string (obj => <string>)
+ (typecase obj
+ (<str> (<gnu.lists.FString> obj))
+ ((satisfies string?) obj)
+ ((satisfies symbol?) (symbol->string obj))
+ (<java.lang.StringBuffer> (<gnu.lists.FString> obj))
+ (<java.lang.StringBuilder> (<gnu.lists.FString> obj))
+ (#t (error "Not a string designator" obj
+ (class-name-sans-package obj)))))
+
+(df to-str (obj => <str>)
+ (cond ((instance? obj <str>) obj)
+ ((string? obj) (! toString obj))
+ ((symbol? obj) (! getName (as <gnu.mapping.Symbol> obj)))
+ (#t (error "Not a string designator" obj
+ (class-name-sans-package obj)))))
+
+))
+
+;; Local Variables:
+;; mode: goo
+;; compile-command: "\
+;; rm -rf classes && \
+;; JAVA_OPTS=-Xss2M kawa --r7rs -d classes -C swank-kawa.scm && \
+;; jar cf swank-kawa.jar -C classes ."
+;; End:
diff --git a/vim/bundle/slimv/slime/contrib/swank-larceny.scm b/vim/bundle/slimv/slime/contrib/swank-larceny.scm
new file mode 100644
index 0000000..e4d730d
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-larceny.scm
@@ -0,0 +1,176 @@
+;; swank-larceny.scm --- Swank server for Larceny
+;;
+;; License: Public Domain
+;; Author: Helmut Eller
+;;
+;; In a shell execute:
+;; larceny -r6rs -program swank-larceny.scm
+;; and then `M-x slime-connect' in Emacs.
+
+(library (swank os)
+ (export getpid make-server-socket accept local-port close-socket)
+ (import (rnrs)
+ (primitives foreign-procedure
+ ffi/handle->address
+ ffi/string->asciiz
+ sizeof:pointer
+ sizeof:int
+ %set-pointer
+ %get-int))
+
+ (define getpid (foreign-procedure "getpid" '() 'int))
+ (define fork (foreign-procedure "fork" '() 'int))
+ (define close (foreign-procedure "close" '(int) 'int))
+ (define dup2 (foreign-procedure "dup2" '(int int) 'int))
+
+ (define bytevector-content-offset$ sizeof:pointer)
+
+ (define execvp% (foreign-procedure "execvp" '(string boxed) 'int))
+ (define (execvp file . args)
+ (let* ((nargs (length args))
+ (argv (make-bytevector (* (+ nargs 1)
+ sizeof:pointer))))
+ (do ((offset 0 (+ offset sizeof:pointer))
+ (as args (cdr as)))
+ ((null? as))
+ (%set-pointer argv
+ offset
+ (+ (ffi/handle->address (ffi/string->asciiz (car as)))
+ bytevector-content-offset$)))
+ (%set-pointer argv (* nargs sizeof:pointer) 0)
+ (execvp% file argv)))
+
+ (define pipe% (foreign-procedure "pipe" '(boxed) 'int))
+ (define (pipe)
+ (let ((array (make-bytevector (* sizeof:int 2))))
+ (let ((r (pipe% array)))
+ (values r (%get-int array 0) (%get-int array sizeof:int)))))
+
+ (define (fork/exec file . args)
+ (let ((pid (fork)))
+ (cond ((= pid 0)
+ (apply execvp file args))
+ (#t pid))))
+
+ (define (start-process file . args)
+ (let-values (((r1 down-out down-in) (pipe))
+ ((r2 up-out up-in) (pipe))
+ ((r3 err-out err-in) (pipe)))
+ (assert (= 0 r1))
+ (assert (= 0 r2))
+ (assert (= 0 r3))
+ (let ((pid (fork)))
+ (case pid
+ ((-1)
+ (error "Failed to fork a subprocess."))
+ ((0)
+ (close up-out)
+ (close err-out)
+ (close down-in)
+ (dup2 down-out 0)
+ (dup2 up-in 1)
+ (dup2 err-in 2)
+ (apply execvp file args)
+ (exit 1))
+ (else
+ (close down-out)
+ (close up-in)
+ (close err-in)
+ (list pid
+ (make-fd-io-stream up-out down-in)
+ (make-fd-io-stream err-out err-out)))))))
+
+ (define (make-fd-io-stream in out)
+ (let ((write (lambda (bv start count) (fd-write out bv start count)))
+ (read (lambda (bv start count) (fd-read in bv start count)))
+ (closeit (lambda () (close in) (close out))))
+ (make-custom-binary-input/output-port
+ "fd-stream" read write #f #f closeit)))
+
+ (define write% (foreign-procedure "write" '(int ulong int) 'int))
+ (define (fd-write fd bytevector start count)
+ (write% fd
+ (+ (ffi/handle->address bytevector)
+ bytevector-content-offset$
+ start)
+ count))
+
+ (define read% (foreign-procedure "read" '(int ulong int) 'int))
+ (define (fd-read fd bytevector start count)
+ ;;(printf "fd-read: ~a ~s ~a ~a\n" fd bytevector start count)
+ (read% fd
+ (+ (ffi/handle->address bytevector)
+ bytevector-content-offset$
+ start)
+ count))
+
+ (define (make-server-socket port)
+ (let* ((args `("/bin/bash" "bash"
+ "-c"
+ ,(string-append
+ "netcat -s 127.0.0.1 -q 0 -l -v "
+ (if port
+ (string-append "-p " (number->string port))
+ ""))))
+ (nc (apply start-process args))
+ (err (transcoded-port (list-ref nc 2)
+ (make-transcoder (latin-1-codec))))
+ (line (get-line err))
+ (pos (last-index-of line '#\])))
+ (cond (pos
+ (let* ((tail (substring line (+ pos 1) (string-length line)))
+ (port (get-datum (open-string-input-port tail))))
+ (list (car nc) (cadr nc) err port)))
+ (#t (error "netcat failed: " line)))))
+
+ (define (accept socket codec)
+ (let* ((line (get-line (caddr socket)))
+ (pos (last-index-of line #\])))
+ (cond (pos
+ (close-port (caddr socket))
+ (let ((stream (cadr socket)))
+ (let ((io (transcoded-port stream (make-transcoder codec))))
+ (values io io))))
+ (else (error "accept failed: " line)))))
+
+ (define (local-port socket)
+ (list-ref socket 3))
+
+ (define (last-index-of str chr)
+ (let loop ((i (string-length str)))
+ (cond ((<= i 0) #f)
+ (#t (let ((i (- i 1)))
+ (cond ((char=? (string-ref str i) chr)
+ i)
+ (#t
+ (loop i))))))))
+
+ (define (close-socket socket)
+ ;;(close-port (cadr socket))
+ #f
+ )
+
+ )
+
+(library (swank sys)
+ (export implementation-name eval-in-interaction-environment)
+ (import (rnrs)
+ (primitives system-features
+ aeryn-evaluator))
+
+ (define (implementation-name) "larceny")
+
+ ;; see $LARCENY/r6rsmode.sch:
+ ;; Larceny's ERR5RS and R6RS modes.
+ ;; Code names:
+ ;; Aeryn ERR5RS
+ ;; D'Argo R6RS-compatible
+ ;; Spanky R6RS-conforming (not yet implemented)
+ (define (eval-in-interaction-environment form)
+ (aeryn-evaluator form))
+
+ )
+
+(import (rnrs) (rnrs eval) (larceny load))
+(load "swank-r6rs.scm")
+(eval '(start-server #f) (environment '(swank)))
diff --git a/vim/bundle/slimv/slime/contrib/swank-listener-hooks.lisp b/vim/bundle/slimv/slime/contrib/swank-listener-hooks.lisp
new file mode 100644
index 0000000..f289c90
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-listener-hooks.lisp
@@ -0,0 +1,91 @@
+;;; swank-listener-hooks.lisp --- listener with special hooks
+;;
+;; Author: Alan Ruttenberg <alanr-l@mumble.net>
+
+;; Provides *slime-repl-eval-hooks* special variable which
+;; can be used for easy interception of SLIME REPL form evaluation
+;; for purposes such as integration with application event loop.
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (swank-require :swank-repl))
+
+(defvar *slime-repl-advance-history* nil
+ "In the dynamic scope of a single form typed at the repl, is set to nil to
+ prevent the repl from advancing the history - * ** *** etc.")
+
+(defvar *slime-repl-suppress-output* nil
+ "In the dynamic scope of a single form typed at the repl, is set to nil to
+ prevent the repl from printing the result of the evalation.")
+
+(defvar *slime-repl-eval-hook-pass* (gensym "PASS")
+ "Token to indicate that a repl hook declines to evaluate the form")
+
+(defvar *slime-repl-eval-hooks* nil
+ "A list of functions. When the repl is about to eval a form, first try running each of
+ these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass*
+ is considered a replacement for calling eval. If there are no hooks, or all
+ pass, then eval is used.")
+
+(export '*slime-repl-eval-hooks*)
+
+(defslimefun repl-eval-hook-pass ()
+ "call when repl hook declines to evaluate the form"
+ (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*))
+
+(defslimefun repl-suppress-output ()
+ "In the dynamic scope of a single form typed at the repl, call to
+ prevent the repl from printing the result of the evalation."
+ (setq *slime-repl-suppress-output* t))
+
+(defslimefun repl-suppress-advance-history ()
+ "In the dynamic scope of a single form typed at the repl, call to
+ prevent the repl from advancing the history - * ** *** etc."
+ (setq *slime-repl-advance-history* nil))
+
+(defun %eval-region (string)
+ (with-input-from-string (stream string)
+ (let (- values)
+ (loop
+ (let ((form (read stream nil stream)))
+ (when (eq form stream)
+ (fresh-line)
+ (finish-output)
+ (return (values values -)))
+ (setq - form)
+ (if *slime-repl-eval-hooks*
+ (setq values (run-repl-eval-hooks form))
+ (setq values (multiple-value-list (eval form))))
+ (finish-output))))))
+
+(defun run-repl-eval-hooks (form)
+ (loop for hook in *slime-repl-eval-hooks*
+ for res = (catch *slime-repl-eval-hook-pass*
+ (multiple-value-list (funcall hook form)))
+ until (not (eq res *slime-repl-eval-hook-pass*))
+ finally (return
+ (if (eq res *slime-repl-eval-hook-pass*)
+ (multiple-value-list (eval form))
+ res))))
+
+(defun %listener-eval (string)
+ (clear-user-input)
+ (with-buffer-syntax ()
+ (swank-repl::track-package
+ (lambda ()
+ (let ((*slime-repl-suppress-output* :unset)
+ (*slime-repl-advance-history* :unset))
+ (multiple-value-bind (values last-form) (%eval-region string)
+ (unless (or (and (eq values nil) (eq last-form nil))
+ (eq *slime-repl-advance-history* nil))
+ (setq *** ** ** * * (car values)
+ /// // // / / values))
+ (setq +++ ++ ++ + + last-form)
+ (unless (eq *slime-repl-suppress-output* t)
+ (funcall swank-repl::*send-repl-results-function* values)))))))
+ nil)
+
+(setq swank-repl::*listener-eval-function* '%listener-eval)
+
+(provide :swank-listener-hooks)
diff --git a/vim/bundle/slimv/slime/contrib/swank-macrostep.lisp b/vim/bundle/slimv/slime/contrib/swank-macrostep.lisp
new file mode 100644
index 0000000..77dfa3f
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-macrostep.lisp
@@ -0,0 +1,227 @@
+;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el
+;;
+;; Authors: Luís Oliveira <luismbo@gmail.com>
+;; Jon Oddie <j.j.oddie@gmail.com>
+;;
+;; License: Public Domain
+
+(defpackage swank-macrostep
+ (:use cl swank)
+ (:import-from swank
+ #:*macroexpand-printer-bindings*
+ #:with-buffer-syntax
+ #:with-bindings
+ #:to-string
+ #:macroexpand-all
+ #:compiler-macroexpand-1
+ #:defslimefun
+ #:collect-macro-forms)
+ (:export #:macrostep-expand-1
+ #:macro-form-p))
+
+(in-package #:swank-macrostep)
+
+(defslimefun macrostep-expand-1 (string compiler-macros? context)
+ (with-buffer-syntax ()
+ (let ((form (read-from-string string)))
+ (multiple-value-bind (expansion error-message)
+ (expand-form-once form compiler-macros? context)
+ (if error-message
+ `(:error ,error-message)
+ (multiple-value-bind (macros compiler-macros)
+ (collect-macro-forms-in-context expansion context)
+ (let* ((all-macros (append macros compiler-macros))
+ (pretty-expansion (pprint-to-string expansion))
+ (positions (collect-form-positions expansion
+ pretty-expansion
+ all-macros))
+ (subform-info
+ (loop
+ for form in all-macros
+ for (start end) in positions
+ when (and start end)
+ collect (let ((op-name (to-string (first form)))
+ (op-type
+ (if (member form macros)
+ :macro
+ :compiler-macro)))
+ (list op-name
+ op-type
+ start)))))
+ `(:ok ,pretty-expansion ,subform-info))))))))
+
+(defun expand-form-once (form compiler-macros? context)
+ (multiple-value-bind (expansion expanded?)
+ (macroexpand-1-in-context form context)
+ (if expanded?
+ (values expansion nil)
+ (if (not compiler-macros?)
+ (values nil "Not a macro form")
+ (multiple-value-bind (expansion expanded?)
+ (compiler-macroexpand-1 form)
+ (if expanded?
+ (values expansion nil)
+ (values nil "Not a macro or compiler-macro form")))))))
+
+(defslimefun macro-form-p (string compiler-macros? context)
+ (with-buffer-syntax ()
+ (let ((form
+ (handler-case
+ (read-from-string string)
+ (error (condition)
+ (unless (debug-on-swank-error)
+ (return-from macro-form-p
+ `(:error ,(format nil "Read error: ~A" condition))))))))
+ `(:ok ,(macro-form-type form compiler-macros? context)))))
+
+(defun macro-form-type (form compiler-macros? context)
+ (cond
+ ((or (not (consp form))
+ (not (symbolp (car form))))
+ nil)
+ ((multiple-value-bind (expansion expanded?)
+ (macroexpand-1-in-context form context)
+ (declare (ignore expansion))
+ expanded?)
+ :macro)
+ ((and compiler-macros?
+ (multiple-value-bind (expansion expanded?)
+ (compiler-macroexpand-1 form)
+ (declare (ignore expansion))
+ expanded?))
+ :compiler-macro)
+ (t
+ nil)))
+
+
+;;;; Hacks to support macro-expansion within local context
+
+(defparameter *macrostep-tag* (gensym))
+
+(defparameter *macrostep-placeholder* '*macrostep-placeholder*)
+
+(define-condition expansion-in-context-failed (simple-error)
+ ())
+
+(defmacro throw-expansion (form &environment env)
+ (throw *macrostep-tag* (macroexpand-1 form env)))
+
+(defmacro throw-collected-macro-forms (form &environment env)
+ (throw *macrostep-tag* (collect-macro-forms form env)))
+
+(defun macroexpand-1-in-context (form context)
+ (handler-case
+ (macroexpand-and-catch
+ `(throw-expansion ,form) context)
+ (error ()
+ (macroexpand-1 form))))
+
+(defun collect-macro-forms-in-context (form context)
+ (handler-case
+ (macroexpand-and-catch
+ `(throw-collected-macro-forms ,form) context)
+ (error ()
+ (collect-macro-forms form))))
+
+(defun macroexpand-and-catch (form context)
+ (catch *macrostep-tag*
+ (macroexpand-all (enclose-form-in-context form context))
+ (error 'expansion-in-context-failed)))
+
+(defun enclose-form-in-context (form context)
+ (with-buffer-syntax ()
+ (destructuring-bind (prefix suffix) context
+ (let* ((placeholder-form
+ (read-from-string
+ (concatenate
+ 'string
+ prefix (prin1-to-string *macrostep-placeholder*) suffix)))
+ (substituted-form (subst form *macrostep-placeholder*
+ placeholder-form)))
+ (if (not (equal placeholder-form substituted-form))
+ substituted-form
+ (error 'expansion-in-context-failed))))))
+
+
+;;;; Tracking Pretty Printer
+
+(defun marker-char-p (char)
+ (<= #xe000 (char-code char) #xe8ff))
+
+(defun make-marker-char (id)
+ ;; using the private-use characters U+E000..U+F8FF as markers, so
+ ;; that's our upper limit for how many we can use.
+ (assert (<= 0 id #x8ff))
+ (code-char (+ #xe000 id)))
+
+(defun marker-char-id (char)
+ (assert (marker-char-p char))
+ (- (char-code char) #xe000))
+
+(defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32)))
+
+(defun whitespacep (char)
+ (member char +whitespace+))
+
+(defun pprint-to-string (object &optional pprint-dispatch)
+ (let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*)))
+ (with-bindings *macroexpand-printer-bindings*
+ (to-string object))))
+
+#-clisp
+(defun collect-form-positions (expansion printed-expansion forms)
+ (loop for (start end)
+ in (collect-marker-positions
+ (pprint-to-string expansion (make-tracking-pprint-dispatch forms))
+ (length forms))
+ collect (when (and start end)
+ (list (find-non-whitespace-position printed-expansion start)
+ (find-non-whitespace-position printed-expansion end)))))
+
+;; The pprint-dispatch table constructed by
+;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack
+;; overflow under CLISP version 2.49. Make the COLLECT-FORM-POSITIONS
+;; entry point a no-op in thi case, so that basic macro-expansion will
+;; still work (without detection of inner macro forms)
+#+clisp
+(defun collect-form-positions (expansion printed-expansion forms)
+ nil)
+
+(defun make-tracking-pprint-dispatch (forms)
+ (let ((original-table *print-pprint-dispatch*)
+ (table (copy-pprint-dispatch)))
+ (flet ((maybe-write-marker (position stream)
+ (when position
+ (write-char (make-marker-char position) stream))))
+ (set-pprint-dispatch 'cons
+ (lambda (stream cons)
+ (let ((pos (position cons forms)))
+ (maybe-write-marker pos stream)
+ ;; delegate printing to the original table.
+ (funcall (pprint-dispatch cons original-table)
+ stream
+ cons)
+ (maybe-write-marker pos stream)))
+ most-positive-fixnum
+ table))
+ table))
+
+(defun collect-marker-positions (string position-count)
+ (let ((positions (make-array position-count :initial-element nil)))
+ (loop with p = 0
+ for char across string
+ unless (whitespacep char)
+ do (if (marker-char-p char)
+ (push p (aref positions (marker-char-id char)))
+ (incf p)))
+ (map 'list #'reverse positions)))
+
+(defun find-non-whitespace-position (string position)
+ (loop with non-whitespace-position = -1
+ for i from 0 and char across string
+ unless (whitespacep char)
+ do (incf non-whitespace-position)
+ until (eql non-whitespace-position position)
+ finally (return i)))
+
+(provide :swank-macrostep)
diff --git a/vim/bundle/slimv/slime/contrib/swank-media.lisp b/vim/bundle/slimv/slime/contrib/swank-media.lisp
new file mode 100644
index 0000000..3d5ef7c
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-media.lisp
@@ -0,0 +1,25 @@
+;;; swank-media.lisp --- insert other media (images)
+;;
+;; Authors: Christophe Rhodes <csr21@cantab.net>
+;;
+;; Licence: GPLv2 or later
+;;
+
+(in-package :swank)
+
+;; this file is empty of functionality. The slime-media contrib
+;; allows swank to return messages other than :write-string as repl
+;; results; this is used in the R implementation of swank to display R
+;; objects with graphical representations (such as trellis objects) as
+;; image presentations in the swank repl. In R, this is done by
+;; having a hook function for the preparation of the repl results, in
+;; addition to the already-existing hook for sending the repl results
+;; (*send-repl-results-function*, used by swank-presentations.lisp).
+;; The swank-media.R contrib implementation defines a generic function
+;; for use as this hook, along with methods for commonly-encountered
+;; graphical R objects. (This strategy is harder in CL, where methods
+;; can only be defined if their specializers already exist; in R's S3
+;; object system, methods are ordinary functions with a special naming
+;; convention)
+
+(provide :swank-media)
diff --git a/vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm b/vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm
new file mode 100644
index 0000000..98af388
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-mit-scheme.scm
@@ -0,0 +1,882 @@
+;;; swank-mit-scheme.scm --- SLIME server for MIT Scheme
+;;
+;; Copyright (C) 2008 Helmut Eller
+;;
+;; This file is licensed under the terms of the GNU General Public
+;; License as distributed with Emacs (press C-h C-c for details).
+
+;;;; Installation:
+#|
+
+1. You need MIT Scheme 9.2
+
+2. The Emacs side needs some fiddling. I have the following in
+ my .emacs:
+
+(setq slime-lisp-implementations
+ '((mit-scheme ("mit-scheme") :init mit-scheme-init)))
+
+(defun mit-scheme-init (file encoding)
+ (format "%S\n\n"
+ `(begin
+ (load-option 'format)
+ (load-option 'sos)
+ (eval
+ '(create-package-from-description
+ (make-package-description '(swank) (list (list))
+ (vector) (vector) (vector) false))
+ (->environment '(package)))
+ (load ,(expand-file-name
+ ".../contrib/swank-mit-scheme.scm" ; <-- insert your path
+ slime-path)
+ (->environment '(swank)))
+ (eval '(start-swank ,file) (->environment '(swank))))))
+
+(defun mit-scheme ()
+ (interactive)
+ (slime 'mit-scheme))
+
+(defun find-mit-scheme-package ()
+ (save-excursion
+ (let ((case-fold-search t))
+ (and (re-search-backward "^[;]+ package: \\((.+)\\).*$" nil t)
+ (match-string-no-properties 1)))))
+
+(setq slime-find-buffer-package-function 'find-mit-scheme-package)
+(add-hook 'scheme-mode-hook (lambda () (slime-mode 1)))
+
+ The `mit-scheme-init' function first loads the SOS and FORMAT
+ libraries, then creates a package "(swank)", and loads this file
+ into that package. Finally it starts the server.
+
+ `find-mit-scheme-package' tries to figure out which package the
+ buffer belongs to, assuming that ";;; package: (FOO)" appears
+ somewhere in the file. Luckily, this assumption is true for many of
+ MIT Scheme's own files. Alternatively, you could add Emacs style
+ -*- slime-buffer-package: "(FOO)" -*- file variables.
+
+4. Start everything with `M-x mit-scheme'.
+
+|#
+
+;;; package: (swank)
+
+;; Modified for Slimv:
+;; - load options
+;; - remove extension in compile-file-for-emacs
+(load-option 'format)
+(load-option 'sos)
+
+(if (< (car (get-subsystem-version "Release"))
+ '9)
+ (error "This file requires MIT Scheme Release 9"))
+
+(define (swank port)
+ (accept-connections (or port 4005) #f))
+
+;; ### hardcoded port number for now. netcat-openbsd doesn't print
+;; the listener port anymore.
+(define (start-swank port-file)
+ (accept-connections 4055 port-file)
+ )
+
+;;;; Networking
+
+(define (accept-connections port port-file)
+ (let ((sock (open-tcp-server-socket port (host-address-loopback))))
+ (format #t "Listening on port: ~s~%" port)
+ (if port-file (write-port-file port port-file))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () (serve (tcp-server-connection-accept sock #t #f)))
+ (lambda () (close-tcp-server-socket sock)))))
+
+(define (write-port-file portnumber filename)
+ (call-with-output-file filename (lambda (p) (write portnumber p))))
+
+(define *top-level-restart* #f)
+(define (serve socket)
+ (with-simple-restart
+ 'disconnect "Close connection."
+ (lambda ()
+ (with-keyboard-interrupt-handler
+ (lambda () (main-loop socket))))))
+
+(define (disconnect)
+ (format #t "Disconnecting ...~%")
+ (invoke-restart (find-restart 'disconnect)))
+
+(define (main-loop socket)
+ (do () (#f)
+ (with-simple-restart
+ 'abort "Return to SLIME top-level."
+ (lambda ()
+ (fluid-let ((*top-level-restart* (find-restart 'abort)))
+ (dispatch (read-packet socket) socket 0))))))
+
+(define (with-keyboard-interrupt-handler fun)
+ (define (set-^G-handler exp)
+ (eval `(vector-set! keyboard-interrupt-vector (char->ascii #\G) ,exp)
+ (->environment '(runtime interrupt-handler))))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (set-^G-handler
+ `(lambda (char) (with-simple-restart
+ 'continue "Continue from interrupt."
+ (lambda () (error "Keyboard Interrupt.")))))
+ (fun))
+ (lambda ()
+ (set-^G-handler '^G-interrupt-handler))))
+
+
+;;;; Reading/Writing of SLIME packets
+
+(define (read-packet in)
+ "Read an S-expression from STREAM using the SLIME protocol."
+ (let* ((len (read-length in))
+ (buffer (make-string len)))
+ (fill-buffer! in buffer)
+ (read-from-string buffer)))
+
+(define (write-packet message out)
+ (let* ((string (write-to-string message)))
+ (log-event "WRITE: [~a]~s~%" (string-length string) string)
+ (write-length (string-length string) out)
+ (write-string string out)
+ (flush-output out)))
+
+(define (fill-buffer! in buffer)
+ (read-string! buffer in))
+
+(define (read-length in)
+ (if (eof-object? (peek-char in)) (disconnect))
+ (do ((len 6 (1- len))
+ (sum 0 (+ (* sum 16) (char->hex-digit (read-char in)))))
+ ((zero? len) sum)))
+
+(define (ldb size position integer)
+ "LoaD a Byte of SIZE bits at bit position POSITION from INTEGER."
+ (fix:and (fix:lsh integer (- position))
+ (1- (fix:lsh 1 size))))
+
+(define (write-length len out)
+ (do ((pos 20 (- pos 4)))
+ ((< pos 0))
+ (write-hex-digit (ldb 4 pos len) out)))
+
+(define (write-hex-digit n out)
+ (write-char (hex-digit->char n) out))
+
+(define (hex-digit->char n)
+ (digit->char n 16))
+
+(define (char->hex-digit c)
+ (char->digit c 16))
+
+
+;;;; Event dispatching
+
+(define (dispatch request socket level)
+ (log-event "READ: ~s~%" request)
+ (case (car request)
+ ((:emacs-rex) (apply emacs-rex socket level (cdr request)))))
+
+(define (swank-package)
+ (or (name->package '(swank))
+ (name->package '(user))))
+
+(define *buffer-package* #f)
+(define (find-buffer-package name)
+ (if (elisp-false? name)
+ #f
+ (let ((v (ignore-errors
+ (lambda () (name->package (read-from-string name))))))
+ (and (package? v) v))))
+
+(define swank-env (->environment (swank-package)))
+(define (user-env buffer-package)
+ (cond ((string? buffer-package)
+ (let ((p (find-buffer-package buffer-package)))
+ (if (not p) (error "Invalid package name: " buffer-package))
+ (package/environment p)))
+ (else (nearest-repl/environment))))
+
+;; quote keywords
+(define (hack-quotes list)
+ (map (lambda (x)
+ (cond ((symbol? x) `(quote ,x))
+ (#t x)))
+ list))
+
+(define (emacs-rex socket level sexp package thread id)
+ (let ((ok? #f) (result #f) (condition #f))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (bind-condition-handler
+ (list condition-type:serious-condition)
+ (lambda (c) (set! condition c) (invoke-sldb socket (1+ level) c))
+ (lambda ()
+ (fluid-let ((*buffer-package* package))
+ (set! result
+ (eval (cons* (car sexp) socket (hack-quotes (cdr sexp)))
+ swank-env))
+ (set! ok? #t)))))
+ (lambda ()
+ (write-packet `(:return
+ ,(if ok? `(:ok ,result)
+ `(:abort
+ ,(if condition
+ (format #f "~a"
+ (condition/type condition))
+ "<unknown reason>")))
+ ,id)
+ socket)))))
+
+(define (swank:connection-info _)
+ (let ((p (environment->package (user-env #f))))
+ `(:pid ,(unix/current-pid)
+ :package (:name ,(write-to-string (package/name p))
+ :prompt ,(write-to-string (package/name p)))
+ :lisp-implementation
+ (:type "MIT Scheme" :version ,(get-subsystem-version-string "release"))
+ :encoding (:coding-systems ("iso-8859-1"))
+ )))
+
+(define (swank:quit-lisp _)
+ (%exit))
+
+
+;;;; Evaluation
+
+(define (swank-repl:listener-eval socket string)
+ ;;(call-with-values (lambda () (eval-region string socket))
+ ;; (lambda values `(:values . ,(map write-to-string values))))
+ `(:values ,(write-to-string (eval-region string socket))))
+
+(define (eval-region string socket)
+ (let ((sexp (read-from-string string)))
+ (if (eof-object? exp)
+ (values)
+ (with-output-to-repl socket
+ (lambda () (eval sexp (user-env *buffer-package*)))))))
+
+(define (with-output-to-repl socket fun)
+ (let ((p (make-port repl-port-type socket)))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () (with-output-to-port p fun))
+ (lambda () (flush-output p)))))
+
+(define (swank:interactive-eval socket string)
+ ;;(call-with-values (lambda () (eval-region string)) format-for-echo-area)
+ (format-values (eval-region string socket))
+ )
+
+(define (format-values . values)
+ (if (null? values)
+ "; No value"
+ (with-string-output-port
+ (lambda (out)
+ (write-string "=> " out)
+ (do ((vs values (cdr vs))) ((null? vs))
+ (write (car vs) out)
+ (if (not (null? (cdr vs)))
+ (write-string ", " out)))))))
+
+(define (swank:pprint-eval _ string)
+ (pprint-to-string (eval (read-from-string string)
+ (user-env *buffer-package*))))
+
+(define (swank:interactive-eval-region socket string)
+ (format-values (eval-region string socket)))
+
+(define (swank:set-package _ package)
+ (set-repl/environment! (nearest-repl)
+ (->environment (read-from-string package)))
+ (let* ((p (environment->package (user-env #f)))
+ (n (write-to-string (package/name p))))
+ (list n n)))
+
+
+(define (repl-write-substring port string start end)
+ (cond ((< start end)
+ (write-packet `(:write-string ,(substring string start end))
+ (port/state port))))
+ (- end start))
+
+(define (repl-write-char port char)
+ (write-packet `(:write-string ,(string char))
+ (port/state port)))
+
+(define repl-port-type
+ (make-port-type `((write-substring ,repl-write-substring)
+ (write-char ,repl-write-char)) #f))
+
+(define (swank-repl:create-repl socket . _)
+ (let* ((env (user-env #f))
+ (name (format #f "~a" (package/name (environment->package env)))))
+ (list name name)))
+
+
+;;;; Compilation
+
+(define (swank:compile-string-for-emacs _ string . x)
+ (apply
+ (lambda (errors seconds)
+ `(:compilation-result ,errors t ,seconds nil nil))
+ (call-compiler
+ (lambda ()
+ (let* ((sexps (snarf-string string))
+ (env (user-env *buffer-package*))
+ (scode (syntax `(begin ,@sexps) env))
+ (compiled-expression (compile-scode scode #t)))
+ (scode-eval compiled-expression env))))))
+
+(define (snarf-string string)
+ (with-input-from-string string
+ (lambda ()
+ (let loop ()
+ (let ((e (read)))
+ (if (eof-object? e) '() (cons e (loop))))))))
+
+(define (call-compiler fun)
+ (let ((time #f))
+ (with-timings fun
+ (lambda (run-time gc-time real-time)
+ (set! time real-time)))
+ (list 'nil (internal-time/ticks->seconds time))))
+
+(define (swank:compiler-notes-for-emacs _) nil)
+
+(define (swank:compile-file-for-emacs socket file load?)
+ (apply
+ (lambda (errors seconds)
+ (list ':compilation-result errors 't seconds load?
+ (->namestring (pathname-name file))))
+ (call-compiler
+ (lambda () (with-output-to-repl socket (lambda () (compile-file file)))))))
+
+(define (swank:load-file socket file)
+ (with-output-to-repl socket
+ (lambda ()
+ (pprint-to-string
+ (load file (user-env *buffer-package*))))))
+
+(define (swank:disassemble-form _ string)
+ (let ((sexp (let ((sexp (read-from-string string)))
+ (cond ((and (pair? sexp) (eq? (car sexp) 'quote))
+ (cadr sexp))
+ (#t sexp)))))
+ (with-output-to-string
+ (lambda ()
+ (compiler:disassemble
+ (eval sexp (user-env *buffer-package*)))))))
+
+(define (swank:disassemble-symbol _ string)
+ (with-output-to-string
+ (lambda ()
+ (compiler:disassemble
+ (eval (read-from-string string)
+ (user-env *buffer-package*))))))
+
+
+;;;; Macroexpansion
+
+(define (swank:swank-macroexpand-all _ string)
+ (with-output-to-string
+ (lambda ()
+ (pp (syntax (read-from-string string)
+ (user-env *buffer-package*))))))
+(define swank:swank-macroexpand-1 swank:swank-macroexpand-all)
+(define swank:swank-macroexpand swank:swank-macroexpand-all)
+
+
+;;; Arglist
+
+(define (swank:operator-arglist socket name pack)
+ (let ((v (ignore-errors
+ (lambda ()
+ (string-trim-right
+ (with-output-to-string
+ (lambda ()
+ (carefully-pa
+ (eval (read-from-string name) (user-env pack))))))))))
+ (if (condition? v) 'nil v)))
+
+(define (carefully-pa o)
+ (cond ((arity-dispatched-procedure? o)
+ ;; MIT Scheme crashes for (pa /)
+ (display "arity-dispatched-procedure"))
+ ((procedure? o) (pa o))
+ (else (error "Not a procedure"))))
+
+
+;;; Some unimplemented stuff.
+(define (swank:buffer-first-change . _) nil)
+(define (swank:filename-to-modulename . _) nil)
+(define (swank:swank-require . _) nil)
+
+;; M-. is beyond my capabilities.
+(define (swank:find-definitions-for-emacs . _) nil)
+
+
+;;; Debugger
+
+(define-structure (sldb-state (conc-name sldb-state.)) condition restarts)
+
+(define *sldb-state* #f)
+(define (invoke-sldb socket level condition)
+ (fluid-let ((*sldb-state* (make-sldb-state condition (bound-restarts))))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (write-packet `(:debug 0 ,level ,@(sldb-info *sldb-state* 0 20))
+ socket)
+ (sldb-loop level socket))
+ (lambda ()
+ (write-packet `(:debug-return 0 ,level nil) socket)))))
+
+(define (sldb-loop level socket)
+ (write-packet `(:debug-activate 0 ,level) socket)
+ (with-simple-restart
+ 'abort (format #f "Return to SLDB level ~a." level)
+ (lambda () (dispatch (read-packet socket) socket level)))
+ (sldb-loop level socket))
+
+(define (sldb-info state start end)
+ (let ((c (sldb-state.condition state))
+ (rs (sldb-state.restarts state)))
+ (list (list (condition/report-string c)
+ (format #f " [~a]" (%condition-type/name (condition/type c)))
+ nil)
+ (sldb-restarts rs)
+ (sldb-backtrace c start end)
+ ;;'((0 "dummy frame"))
+ '())))
+
+(define %condition-type/name
+ (eval '%condition-type/name (->environment '(runtime error-handler))))
+
+(define (sldb-restarts restarts)
+ (map (lambda (r)
+ (list (symbol->string (restart/name r))
+ (with-string-output-port
+ (lambda (p) (write-restart-report r p)))))
+ restarts))
+
+(define (swank:throw-to-toplevel . _)
+ (invoke-restart *top-level-restart*))
+
+(define (swank:sldb-abort . _)
+ (abort (sldb-state.restarts *sldb-state*)))
+
+(define (swank:sldb-continue . _)
+ (continue (sldb-state.restarts *sldb-state*)))
+
+(define (swank:invoke-nth-restart-for-emacs _ _sldb-level n)
+ (invoke-restart (list-ref (sldb-state.restarts *sldb-state*) n)))
+
+(define (swank:debugger-info-for-emacs _ from to)
+ (sldb-info *sldb-state* from to))
+
+(define (swank:backtrace _ from to)
+ (sldb-backtrace (sldb-state.condition *sldb-state*) from to))
+
+(define (sldb-backtrace condition from to)
+ (sldb-backtrace-aux (condition/continuation condition) from to))
+
+(define (sldb-backtrace-aux k from to)
+ (let ((l (map frame>string (substream (continuation>frames k) from to))))
+ (let loop ((i from) (l l))
+ (if (null? l)
+ '()
+ (cons (list i (car l)) (loop (1+ i) (cdr l)))))))
+
+;; Stack parser fails for this:
+;; (map (lambda (x) x) "/tmp/x.x")
+
+(define (continuation>frames k)
+ (let loop ((frame (continuation->stack-frame k)))
+ (cond ((not frame) (stream))
+ (else
+ (let ((next (ignore-errors
+ (lambda () (stack-frame/next-subproblem frame)))))
+ (cons-stream frame
+ (if (condition? next)
+ (stream next)
+ (loop next))))))))
+
+(define (frame>string frame)
+ (if (condition? frame)
+ (format #f "Bogus frame: ~a ~a" frame
+ (condition/report-string frame))
+ (with-string-output-port (lambda (p) (print-frame frame p)))))
+
+(define (print-frame frame port)
+ (define (invalid-subexpression? subexpression)
+ (or (debugging-info/undefined-expression? subexpression)
+ (debugging-info/unknown-expression? subexpression)))
+ (define (invalid-expression? expression)
+ (or (debugging-info/undefined-expression? expression)
+ (debugging-info/compiled-code? expression)))
+ (with-values (lambda () (stack-frame/debugging-info frame))
+ (lambda (expression environment subexpression)
+ (cond ((debugging-info/compiled-code? expression)
+ (write-string ";unknown compiled code" port))
+ ((not (debugging-info/undefined-expression? expression))
+ (fluid-let ((*unparse-primitives-by-name?* #t))
+ (write
+ (unsyntax (if (invalid-subexpression? subexpression)
+ expression
+ subexpression))
+ port)))
+ ((debugging-info/noise? expression)
+ (write-string ";" port)
+ (write-string ((debugging-info/noise expression) #f)
+ port))
+ (else
+ (write-string ";undefined expression" port))))))
+
+(define (substream s from to)
+ (let loop ((i 0) (l '()) (s s))
+ (cond ((or (= i to) (stream-null? s)) (reverse l))
+ ((< i from) (loop (1+ i) l (stream-cdr s)))
+ (else (loop (1+ i) (cons (stream-car s) l) (stream-cdr s))))))
+
+(define (swank:frame-locals-and-catch-tags _ frame)
+ (list (map frame-var>elisp (frame-vars (sldb-get-frame frame)))
+ '()))
+
+(define (frame-vars frame)
+ (with-values (lambda () (stack-frame/debugging-info frame))
+ (lambda (expression environment subexpression)
+ (cond ((environment? environment)
+ (environment>frame-vars environment))
+ (else '())))))
+
+(define (environment>frame-vars environment)
+ (let loop ((e environment))
+ (cond ((environment->package e) '())
+ (else (append (environment-bindings e)
+ (if (environment-has-parent? e)
+ (loop (environment-parent e))
+ '()))))))
+
+(define (frame-var>elisp b)
+ (list ':name (write-to-string (car b))
+ ':value (cond ((null? (cdr b)) "{unavailable}")
+ (else (>line (cadr b))))
+ ':id 0))
+
+(define (sldb-get-frame index)
+ (stream-ref (continuation>frames
+ (condition/continuation
+ (sldb-state.condition *sldb-state*)))
+ index))
+
+(define (frame-var-value frame var)
+ (let ((binding (list-ref (frame-vars frame) var)))
+ (cond ((cdr binding) (cadr binding))
+ (else unspecific))))
+
+(define (swank:inspect-frame-var _ frame var)
+ (reset-inspector)
+ (inspect-object (frame-var-value (sldb-get-frame frame) var)))
+
+
+;;;; Completion
+
+(define (swank:simple-completions _ string package)
+ (let ((strings (all-completions string (user-env package) string-prefix?)))
+ (list (sort strings string<?)
+ (longest-common-prefix strings))))
+
+(define (all-completions pattern env match?)
+ (let ((ss (map %symbol->string (environment-names env))))
+ (keep-matching-items ss (lambda (s) (match? pattern s)))))
+
+;; symbol->string is too slow
+(define %symbol->string symbol-name)
+
+(define (environment-names env)
+ (append (environment-bound-names env)
+ (if (environment-has-parent? env)
+ (environment-names (environment-parent env))
+ '())))
+
+(define (longest-common-prefix strings)
+ (define (common-prefix s1 s2)
+ (substring s1 0 (string-match-forward s1 s2)))
+ (reduce common-prefix "" strings))
+
+
+;;;; Apropos
+
+(define (swank:apropos-list-for-emacs _ name #!optional
+ external-only case-sensitive package)
+ (let* ((pkg (and (string? package)
+ (find-package (read-from-string package))))
+ (parent (and (not (default-object? external-only))
+ (elisp-false? external-only)))
+ (ss (append-map (lambda (p)
+ (map (lambda (s) (cons p s))
+ (apropos-list name p (and pkg parent))))
+ (if pkg (list pkg) (all-packages))))
+ (ss (sublist ss 0 (min (length ss) 200))))
+ (map (lambda (e)
+ (let ((p (car e)) (s (cdr e)))
+ (list ':designator (format #f "~a ~a" s (package/name p))
+ ':variable (>line
+ (ignore-errors
+ (lambda () (package-lookup p s)))))))
+ ss)))
+
+(define (swank:list-all-package-names . _)
+ (map (lambda (p) (write-to-string (package/name p)))
+ (all-packages)))
+
+(define (all-packages)
+ (define (package-and-children package)
+ (append (list package)
+ (append-map package-and-children (package/children package))))
+ (package-and-children system-global-package))
+
+
+;;;; Inspector
+
+(define-structure (inspector-state (conc-name istate.))
+ object parts next previous content)
+
+(define istate #f)
+
+(define (reset-inspector)
+ (set! istate #f))
+
+(define (swank:init-inspector _ string)
+ (reset-inspector)
+ (inspect-object (eval (read-from-string string)
+ (user-env *buffer-package*))))
+
+(define (inspect-object o)
+ (let ((previous istate)
+ (content (inspect o))
+ (parts (make-eqv-hash-table)))
+ (set! istate (make-inspector-state o parts #f previous content))
+ (if previous (set-istate.next! previous istate))
+ (istate>elisp istate)))
+
+(define (istate>elisp istate)
+ (list ':title (>line (istate.object istate))
+ ':id (assign-index (istate.object istate) (istate.parts istate))
+ ':content (prepare-range (istate.parts istate)
+ (istate.content istate)
+ 0 500)))
+
+(define (assign-index o parts)
+ (let ((i (hash-table/count parts)))
+ (hash-table/put! parts i o)
+ i))
+
+(define (prepare-range parts content from to)
+ (let* ((cs (substream content from to))
+ (ps (prepare-parts cs parts)))
+ (list ps
+ (if (< (length cs) (- to from))
+ (+ from (length cs))
+ (+ to 1000))
+ from to)))
+
+(define (prepare-parts ps parts)
+ (define (line label value)
+ `(,(format #f "~a: " label)
+ (:value ,(>line value) ,(assign-index value parts))
+ "\n"))
+ (append-map (lambda (p)
+ (cond ((string? p) (list p))
+ ((symbol? p) (list (symbol->string p)))
+ (#t
+ (case (car p)
+ ((line) (apply line (cdr p)))
+ (else (error "Invalid part:" p))))))
+ ps))
+
+(define (swank:inspect-nth-part _ index)
+ (inspect-object (hash-table/get (istate.parts istate) index 'no-such-part)))
+
+(define (swank:quit-inspector _)
+ (reset-inspector))
+
+(define (swank:inspector-pop _)
+ (cond ((istate.previous istate)
+ (set! istate (istate.previous istate))
+ (istate>elisp istate))
+ (else 'nil)))
+
+(define (swank:inspector-next _)
+ (cond ((istate.next istate)
+ (set! istate (istate.next istate))
+ (istate>elisp istate))
+ (else 'nil)))
+
+(define (swank:inspector-range _ from to)
+ (prepare-range (istate.parts istate)
+ (istate.content istate)
+ from to))
+
+(define-syntax stream*
+ (syntax-rules ()
+ ((stream* tail) tail)
+ ((stream* e1 e2 ...) (cons-stream e1 (stream* e2 ...)))))
+
+(define (iline label value) `(line ,label ,value))
+
+(define-generic inspect (o))
+
+(define-method inspect ((o <object>))
+ (cond ((environment? o) (inspect-environment o))
+ ((vector? o) (inspect-vector o))
+ ((procedure? o) (inspect-procedure o))
+ ((compiled-code-block? o) (inspect-code-block o))
+ ;;((system-pair? o) (inspect-system-pair o))
+ ((probably-scode? o) (inspect-scode o))
+ (else (inspect-fallback o))))
+
+(define (inspect-fallback o)
+ (let* ((class (object-class o))
+ (slots (class-slots class)))
+ (stream*
+ (iline "Class" class)
+ (let loop ((slots slots))
+ (cond ((null? slots) (stream))
+ (else
+ (let ((n (slot-name (car slots))))
+ (stream* (iline n (slot-value o n))
+ (loop (cdr slots))))))))))
+
+(define-method inspect ((o <pair>))
+ (if (or (pair? (cdr o)) (null? (cdr o)))
+ (inspect-list o)
+ (inspect-cons o)))
+
+(define (inspect-cons o)
+ (stream (iline "car" (car o))
+ (iline "cdr" (cdr o))))
+
+(define (inspect-list o)
+ (let loop ((i 0) (o o))
+ (cond ((null? o) (stream))
+ ((or (pair? (cdr o)) (null? (cdr o)))
+ (stream* (iline i (car o))
+ (loop (1+ i) (cdr o))))
+ (else
+ (stream (iline i (car o))
+ (iline "tail" (cdr o)))))))
+
+(define (inspect-environment o)
+ (stream*
+ (iline "(package)" (environment->package o))
+ (let loop ((bs (environment-bindings o)))
+ (cond ((null? bs)
+ (if (environment-has-parent? o)
+ (stream (iline "(<parent>)" (environment-parent o)))
+ (stream)))
+ (else
+ (let* ((b (car bs)) (s (car b)))
+ (cond ((null? (cdr b))
+ (stream* s " {" (environment-reference-type o s) "}\n"
+ (loop (cdr bs))))
+ (else
+ (stream* (iline s (cadr b))
+ (loop (cdr bs)))))))))))
+
+(define (inspect-vector o)
+ (let ((len (vector-length o)))
+ (let loop ((i 0))
+ (cond ((= i len) (stream))
+ (else (stream* (iline i (vector-ref o i))
+ (loop (1+ i))))))))
+
+(define (inspect-procedure o)
+ (cond ((primitive-procedure? o)
+ (stream (iline "name" (primitive-procedure-name o))
+ (iline "arity" (primitive-procedure-arity o))
+ (iline "doc" (primitive-procedure-documentation o))))
+ ((compound-procedure? o)
+ (stream (iline "arity" (procedure-arity o))
+ (iline "lambda" (procedure-lambda o))
+ (iline "env" (ignore-errors
+ (lambda () (procedure-environment o))))))
+ (else
+ (stream
+ (iline "block" (compiled-entry/block o))
+ (with-output-to-string (lambda () (compiler:disassemble o)))))))
+
+(define (inspect-code-block o)
+ (stream-append
+ (let loop ((i (compiled-code-block/constants-start o)))
+ (cond ((>= i (compiled-code-block/constants-end o)) (stream))
+ (else
+ (stream*
+ (iline i (system-vector-ref o i))
+ (loop (+ i compiled-code-block/bytes-per-object))))))
+ (stream (iline "debuginfo" (compiled-code-block/debugging-info o))
+ (iline "env" (compiled-code-block/environment o))
+ (with-output-to-string (lambda () (compiler:disassemble o))))))
+
+(define (inspect-scode o)
+ (stream (pprint-to-string o)))
+
+(define (probably-scode? o)
+ (define tests (list access? assignment? combination? comment?
+ conditional? definition? delay? disjunction? lambda?
+ quotation? sequence? the-environment? variable?))
+ (let loop ((tests tests))
+ (cond ((null? tests) #f)
+ (((car tests) o))
+ (else (loop (cdr tests))))))
+
+(define (inspect-system-pair o)
+ (stream (iline "car" (system-pair-car o))
+ (iline "cdr" (system-pair-cdr o))))
+
+
+;;;; Auxilary functions
+
+(define nil '())
+(define t 't)
+(define (elisp-false? o) (member o '(nil ())))
+(define (elisp-true? o) (not (elisp-false? o)))
+(define (>line o)
+ (let ((r (write-to-string o 100)))
+ (cond ((not (car r)) (cdr r))
+ (else (string-append (cdr r) " ..")))))
+;; Must compile >line otherwise we can't write unassigend-reference-traps.
+(set! >line (compile-procedure >line))
+(define (read-from-string s) (with-input-from-string s read))
+(define (pprint-to-string o)
+ (with-string-output-port
+ (lambda (p)
+ (fluid-let ((*unparser-list-breadth-limit* 10)
+ (*unparser-list-depth-limit* 4)
+ (*unparser-string-length-limit* 100))
+ (pp o p)))))
+;(define (1+ n) (+ n 1))
+(define (1- n) (- n 1))
+(define (package-lookup package name)
+ (let ((p (if (package? package) package (find-package package))))
+ (environment-lookup (package/environment p) name)))
+(define log-port (current-output-port))
+(define (log-event fstring . args)
+ ;;(apply format log-port fstring args)
+ #f
+ )
+
+;; Modified for Slimv:
+;; - restart swank server in a loop
+(let loop ()
+ (swank 4005)
+ (loop))
+
+;;; swank-mit-scheme.scm ends here
diff --git a/vim/bundle/slimv/slime/contrib/swank-mrepl.lisp b/vim/bundle/slimv/slime/contrib/swank-mrepl.lisp
new file mode 100644
index 0000000..cc8ce81
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-mrepl.lisp
@@ -0,0 +1,162 @@
+;;; swank-mrepl.lisp
+;;
+;; Licence: public domain
+
+(in-package :swank)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((api '(
+ *emacs-connection*
+ channel
+ channel-id
+ define-channel-method
+ defslimefun
+ dcase
+ log-event
+ process-requests
+ send-to-remote-channel
+ use-threads-p
+ wait-for-event
+ with-bindings
+ with-connection
+ with-top-level-restart
+ with-slime-interrupts
+ )))
+ (eval `(defpackage #:swank-api
+ (:use)
+ (:import-from #:swank . ,api)
+ (:export . ,api)))))
+
+(defpackage :swank-mrepl
+ (:use :cl :swank-api)
+ (:export #:create-mrepl))
+
+(in-package :swank-mrepl)
+
+(defclass listener-channel (channel)
+ ((remote :initarg :remote)
+ (env :initarg :env)
+ (mode :initform :eval)
+ (tag :initform nil)))
+
+(defun package-prompt (package)
+ (reduce (lambda (x y) (if (<= (length x) (length y)) x y))
+ (cons (package-name package) (package-nicknames package))))
+
+(defslimefun create-mrepl (remote)
+ (let* ((pkg *package*)
+ (conn *emacs-connection*)
+ (thread (if (use-threads-p)
+ (spawn-listener-thread conn)
+ nil))
+ (ch (make-instance 'listener-channel :remote remote :thread thread)))
+ (setf (slot-value ch 'env) (initial-listener-env ch))
+ (when thread
+ (swank/backend:send thread `(:serve-channel ,ch)))
+ (list (channel-id ch)
+ (swank/backend:thread-id (or thread (swank/backend:current-thread)))
+ (package-name pkg)
+ (package-prompt pkg))))
+
+(defun initial-listener-env (listener)
+ `((*package* . ,*package*)
+ (*standard-output* . ,(make-listener-output-stream listener))
+ (*standard-input* . ,(make-listener-input-stream listener))))
+
+(defun spawn-listener-thread (connection)
+ (swank/backend:spawn
+ (lambda ()
+ (with-connection (connection)
+ (dcase (swank/backend:receive)
+ ((:serve-channel c)
+ (loop
+ (with-top-level-restart (connection (drop-unprocessed-events c))
+ (process-requests nil)))))))
+ :name "mrepl thread"))
+
+(defun drop-unprocessed-events (channel)
+ (with-slots (mode) channel
+ (let ((old-mode mode))
+ (setf mode :drop)
+ (unwind-protect
+ (process-requests t)
+ (setf mode old-mode)))
+ (send-prompt channel)))
+
+(define-channel-method :process ((c listener-channel) string)
+ (log-event ":process ~s~%" string)
+ (with-slots (mode remote) c
+ (ecase mode
+ (:eval (mrepl-eval c string))
+ (:read (mrepl-read c string))
+ (:drop))))
+
+(defun mrepl-eval (channel string)
+ (with-slots (remote env) channel
+ (let ((aborted t))
+ (with-bindings env
+ (unwind-protect
+ (let ((result (with-slime-interrupts (read-eval-print string))))
+ (send-to-remote-channel remote `(:write-result ,result))
+ (setq aborted nil))
+ (setf env (loop for (sym) in env
+ collect (cons sym (symbol-value sym))))
+ (cond (aborted
+ (send-to-remote-channel remote `(:evaluation-aborted)))
+ (t
+ (send-prompt channel))))))))
+
+(defun send-prompt (channel)
+ (with-slots (env remote) channel
+ (let ((pkg (or (cdr (assoc '*package* env)) *package*))
+ (out (cdr (assoc '*standard-output* env)))
+ (in (cdr (assoc '*standard-input* env))))
+ (when out (force-output out))
+ (when in (clear-input in))
+ (send-to-remote-channel remote `(:prompt ,(package-name pkg)
+ ,(package-prompt pkg))))))
+
+(defun mrepl-read (channel string)
+ (with-slots (tag) channel
+ (assert tag)
+ (throw tag string)))
+
+(defun read-eval-print (string)
+ (with-input-from-string (in string)
+ (setq / ())
+ (loop
+ (let* ((form (read in nil in)))
+ (cond ((eq form in) (return))
+ (t (setq / (multiple-value-list (eval (setq + form))))))))
+ (force-output)
+ (if /
+ (format nil "~{~s~%~}" /)
+ "; No values")))
+
+(defun make-listener-output-stream (channel)
+ (let ((remote (slot-value channel 'remote)))
+ (swank/backend:make-output-stream
+ (lambda (string)
+ (send-to-remote-channel remote `(:write-string ,string))))))
+
+(defun make-listener-input-stream (channel)
+ (swank/backend:make-input-stream (lambda () (read-input channel))))
+
+(defun set-mode (channel new-mode)
+ (with-slots (mode remote) channel
+ (unless (eq mode new-mode)
+ (send-to-remote-channel remote `(:set-read-mode ,new-mode)))
+ (setf mode new-mode)))
+
+(defun read-input (channel)
+ (with-slots (mode tag remote) channel
+ (force-output)
+ (let ((old-mode mode)
+ (old-tag tag))
+ (setf tag (cons nil nil))
+ (set-mode channel :read)
+ (unwind-protect
+ (catch tag (process-requests nil))
+ (setf tag old-tag)
+ (set-mode channel old-mode)))))
+
+(provide :swank-mrepl)
diff --git a/vim/bundle/slimv/slime/contrib/swank-package-fu.lisp b/vim/bundle/slimv/slime/contrib/swank-package-fu.lisp
new file mode 100644
index 0000000..a22807a
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-package-fu.lisp
@@ -0,0 +1,65 @@
+
+(in-package :swank)
+
+(defslimefun package= (string1 string2)
+ (let* ((pkg1 (guess-package string1))
+ (pkg2 (guess-package string2)))
+ (and pkg1 pkg2 (eq pkg1 pkg2))))
+
+(defslimefun export-symbol-for-emacs (symbol-str package-str)
+ (let ((package (guess-package package-str)))
+ (when package
+ (let ((*buffer-package* package))
+ (export `(,(from-string symbol-str)) package)))))
+
+(defslimefun unexport-symbol-for-emacs (symbol-str package-str)
+ (let ((package (guess-package package-str)))
+ (when package
+ (let ((*buffer-package* package))
+ (unexport `(,(from-string symbol-str)) package)))))
+
+#+sbcl
+(defun list-structure-symbols (name)
+ (let ((dd (sb-kernel:find-defstruct-description name )))
+ (list* name
+ (sb-kernel:dd-default-constructor dd)
+ (sb-kernel:dd-predicate-name dd)
+ (sb-kernel::dd-copier-name dd)
+ (mapcar #'sb-kernel:dsd-accessor-name
+ (sb-kernel:dd-slots dd)))))
+
+#+ccl
+(defun list-structure-symbols (name)
+ (let ((definition (gethash name ccl::%defstructs%)))
+ (list* name
+ (ccl::sd-constructor definition)
+ (ccl::sd-refnames definition))))
+
+(defun list-class-symbols (name)
+ (let* ((class (find-class name))
+ (slots (swank-mop:class-direct-slots class)))
+ (labels ((extract-symbol (name)
+ (if (and (consp name) (eql (car name) 'setf))
+ (cadr name)
+ name))
+ (slot-accessors (slot)
+ (nintersection (copy-list (swank-mop:slot-definition-readers slot))
+ (copy-list (swank-mop:slot-definition-readers slot))
+ :key #'extract-symbol)))
+ (list* (class-name class)
+ (mapcan #'slot-accessors slots)))))
+
+(defslimefun export-structure (name package)
+ (let ((*package* (guess-package package)))
+ (when *package*
+ (let* ((name (from-string name))
+ (symbols (cond #+(or sbcl ccl)
+ ((or (not (find-class name nil))
+ (subtypep name 'structure-object))
+ (list-structure-symbols name))
+ (t
+ (list-class-symbols name)))))
+ (export symbols)
+ symbols))))
+
+(provide :swank-package-fu)
diff --git a/vim/bundle/slimv/slime/contrib/swank-presentation-streams.lisp b/vim/bundle/slimv/slime/contrib/swank-presentation-streams.lisp
new file mode 100644
index 0000000..a83d62e
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-presentation-streams.lisp
@@ -0,0 +1,334 @@
+;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities
+;;; to portions of output
+;;;
+;;; Authors: Alan Ruttenberg <alanr-l@mumble.net>
+;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+;;; Helmut Eller <heller@common-lisp.net>
+;;;
+;;; License: This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (swank-require :swank-presentations))
+
+;; This file contains a mechanism for printing to the slime repl so
+;; that the printed result remembers what object it is associated
+;; with. This extends the recording of REPL results.
+;;
+;; There are two methods:
+;;
+;; 1. Depends on the ilisp bridge code being installed and ready to
+;; intercept messages in the printed stream. We encode the
+;; information with a message saying that we are starting to print
+;; an object corresponding to a given id and another when we are
+;; done. The process filter notices these and adds the necessary
+;; text properties to the output.
+;;
+;; 2. Use separate protocol messages :presentation-start and
+;; :presentation-end for sending presentations.
+;;
+;; We only do this if we know we are printing to a slime stream,
+;; checked with the method slime-stream-p. Initially this checks for
+;; the knows slime streams looking at *connections*. In cmucl, sbcl, and
+;; openmcl it also checks if it is a pretty-printing stream which
+;; ultimately prints to a slime stream.
+;;
+;; Method 1 seems to be faster, but the printed escape sequences can
+;; disturb the column counting, and thus the layout in pretty-printing.
+;; We use method 1 when a dedicated output stream is used.
+;;
+;; Method 2 is cleaner and works with pretty printing if the pretty
+;; printers support "annotations". We use method 2 when no dedicated
+;; output stream is used.
+
+;; Control
+(defvar *enable-presenting-readable-objects* t
+ "set this to enable automatically printing presentations for some
+subset of readable objects, such as pathnames." )
+
+;; doing it
+
+(defmacro presenting-object (object stream &body body)
+ "What you use in your code. Wrap this around some printing and that text will
+be sensitive and remember what object it is in the repl"
+ `(presenting-object-1 ,object ,stream #'(lambda () ,@body)))
+
+(defmacro presenting-object-if (predicate object stream &body body)
+ "What you use in your code. Wrap this around some printing and that text will
+be sensitive and remember what object it is in the repl if predicate is true"
+ (let ((continue (gensym)))
+ `(let ((,continue #'(lambda () ,@body)))
+ (if ,predicate
+ (presenting-object-1 ,object ,stream ,continue)
+ (funcall ,continue)))))
+
+;;; Get pretty printer patches for SBCL at load (not compile) time.
+#+#:disable-dangerous-patching ; #+sbcl
+(eval-when (:load-toplevel)
+ (handler-bind ((simple-error
+ (lambda (c)
+ (declare (ignore c))
+ (let ((clobber-it (find-restart 'sb-kernel::clobber-it)))
+ (when clobber-it (invoke-restart clobber-it))))))
+ (sb-ext:without-package-locks
+ (swank/sbcl::with-debootstrapping
+ (load (make-pathname
+ :name "sbcl-pprint-patch"
+ :type "lisp"
+ :directory (pathname-directory
+ swank-loader:*source-directory*)))))))
+
+(let ((last-stream nil)
+ (last-answer nil))
+ (defun slime-stream-p (stream)
+ "Check if stream is one of the slime streams, since if it isn't we
+don't want to present anything.
+Two special return values:
+:DEDICATED -- Output ends up on a dedicated output stream
+:REPL-RESULT -- Output ends up on the :repl-results target.
+"
+ (if (eq last-stream stream)
+ last-answer
+ (progn
+ (setq last-stream stream)
+ (if (eq stream t)
+ (setq stream *standard-output*))
+ (setq last-answer
+ (or #+openmcl
+ (and (typep stream 'ccl::xp-stream)
+ ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure)))
+ (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1)))
+ #+cmu
+ (or (and (typep stream 'lisp::indenting-stream)
+ (slime-stream-p (lisp::indenting-stream-stream stream)))
+ (and (typep stream 'pretty-print::pretty-stream)
+ (fboundp 'pretty-print::enqueue-annotation)
+ (let ((slime-stream-p
+ (slime-stream-p (pretty-print::pretty-stream-target stream))))
+ (and ;; Printing through CMUCL pretty
+ ;; streams is only cleanly
+ ;; possible if we are using the
+ ;; bridge-less protocol with
+ ;; annotations, because the bridge
+ ;; escape sequences disturb the
+ ;; pretty printer layout.
+ (not (eql slime-stream-p :dedicated-output))
+ ;; If OK, return the return value
+ ;; we got from slime-stream-p on
+ ;; the target stream (could be
+ ;; :repl-result):
+ slime-stream-p))))
+ #+sbcl
+ (let ()
+ (declare (notinline sb-pretty::pretty-stream-target))
+ (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))
+ (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)
+ (not *use-dedicated-output-stream*)
+ (slime-stream-p (sb-pretty::pretty-stream-target stream))))
+ #+allegro
+ (and (typep stream 'excl:xp-simple-stream)
+ (slime-stream-p (excl::stream-output-handle stream)))
+ (loop for connection in *connections*
+ thereis (or (and (eq stream (connection.dedicated-output connection))
+ :dedicated)
+ (eq stream (connection.socket-io connection))
+ (eq stream (connection.user-output connection))
+ (eq stream (connection.user-io connection))
+ (and (eq stream (connection.repl-results connection))
+ :repl-result)))))))))
+
+(defun can-present-readable-objects (&optional stream)
+ (declare (ignore stream))
+ *enable-presenting-readable-objects*)
+
+;; If we are printing to an XP (pretty printing) stream, printing the
+;; escape sequences directly would mess up the layout because column
+;; counting is disturbed. Use "annotations" instead.
+#+allegro
+(defun write-annotation (stream function arg)
+ (if (typep stream 'excl:xp-simple-stream)
+ (excl::schedule-annotation stream function arg)
+ (funcall function arg stream nil)))
+#+cmu
+(defun write-annotation (stream function arg)
+ (if (and (typep stream 'pp:pretty-stream)
+ (fboundp 'pp::enqueue-annotation))
+ (pp::enqueue-annotation stream function arg)
+ (funcall function arg stream nil)))
+#+sbcl
+(defun write-annotation (stream function arg)
+ (let ((enqueue-annotation
+ (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)))
+ (if (and enqueue-annotation
+ (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)))
+ (funcall enqueue-annotation stream function arg)
+ (funcall function arg stream nil))))
+#-(or allegro cmu sbcl)
+(defun write-annotation (stream function arg)
+ (funcall function arg stream nil))
+
+(defstruct presentation-record
+ (id)
+ (printed-p)
+ (target))
+
+(defun presentation-start (record stream truncatep)
+ (unless truncatep
+ ;; Don't start new presentations when nothing is going to be
+ ;; printed due to *print-lines*.
+ (let ((pid (presentation-record-id record))
+ (target (presentation-record-target record)))
+ (case target
+ (:dedicated
+ ;; Use bridge protocol
+ (write-string "<" stream)
+ (prin1 pid stream)
+ (write-string "" stream))
+ (t
+ (finish-output stream)
+ (send-to-emacs `(:presentation-start ,pid ,target)))))
+ (setf (presentation-record-printed-p record) t)))
+
+(defun presentation-end (record stream truncatep)
+ (declare (ignore truncatep))
+ ;; Always end old presentations that were started.
+ (when (presentation-record-printed-p record)
+ (let ((pid (presentation-record-id record))
+ (target (presentation-record-target record)))
+ (case target
+ (:dedicated
+ ;; Use bridge protocol
+ (write-string ">" stream)
+ (prin1 pid stream)
+ (write-string "" stream))
+ (t
+ (finish-output stream)
+ (send-to-emacs `(:presentation-end ,pid ,target)))))))
+
+(defun presenting-object-1 (object stream continue)
+ "Uses the bridge mechanism with two messages >id and <id. The first one
+says that I am starting to print an object with this id. The second says I am finished"
+ ;; this declare special is to let the compiler know that *record-repl-results* will eventually be
+ ;; a global special, even if it isn't when this file is compiled/loaded.
+ (declare (special *record-repl-results*))
+ (let ((slime-stream-p
+ (and *record-repl-results* (slime-stream-p stream))))
+ (if slime-stream-p
+ (let* ((pid (swank::save-presented-object object))
+ (record (make-presentation-record :id pid :printed-p nil
+ :target (if (eq slime-stream-p :repl-result)
+ :repl-result
+ nil))))
+ (write-annotation stream #'presentation-start record)
+ (multiple-value-prog1
+ (funcall continue)
+ (write-annotation stream #'presentation-end record)))
+ (funcall continue))))
+
+(defun present-repl-results-via-presentation-streams (values)
+ ;; Override a function in swank.lisp, so that
+ ;; nested presentations work in the REPL result.
+ (let ((repl-results (connection.repl-results *emacs-connection*)))
+ (flet ((send (value)
+ (presenting-object value repl-results
+ (prin1 value repl-results))
+ (terpri repl-results)))
+ (if (null values)
+ (progn
+ (princ "; No value" repl-results)
+ (terpri repl-results))
+ (mapc #'send values)))
+ (finish-output repl-results)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#+openmcl
+(in-package :ccl)
+
+#+openmcl
+(defun monkey-patch-stream-printing ()
+ (let ((*warn-if-redefine-kernel* nil)
+ (*warn-if-redefine* nil))
+ (defun %print-unreadable-object (object stream type id thunk)
+ (cond ((null stream) (setq stream *standard-output*))
+ ((eq stream t) (setq stream *terminal-io*)))
+ (swank::presenting-object object stream
+ (write-unreadable-start object stream)
+ (when type
+ (princ (type-of object) stream)
+ (stream-write-char stream #\space))
+ (when thunk
+ (funcall thunk))
+ (if id
+ (%write-address object stream #\>)
+ (pp-end-block stream ">"))
+ nil))
+ (defmethod print-object :around ((pathname pathname) stream)
+ (swank::presenting-object-if
+ (swank::can-present-readable-objects stream)
+ pathname stream (call-next-method))))
+ (ccl::def-load-pointers clear-presentations ()
+ (swank::clear-presentation-tables)))
+
+(in-package :swank)
+
+#+cmu
+(progn
+ (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body)
+ (presenting-object object stream
+ (fwrappers:call-next-function)))
+
+ (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth)
+ (presenting-object-if (can-present-readable-objects stream) pathname stream
+ (fwrappers:call-next-function)))
+
+ (defun monkey-patch-stream-printing ()
+ (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper)
+ (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper)))
+
+#+sbcl
+(progn
+ (defvar *saved-%print-unreadable-object*
+ (fdefinition 'sb-impl::%print-unreadable-object))
+
+ (defun monkey-patch-stream-printing ()
+ (sb-ext:without-package-locks
+ (when (eq (fdefinition 'sb-impl::%print-unreadable-object)
+ *saved-%print-unreadable-object*)
+ (setf (fdefinition 'sb-impl::%print-unreadable-object)
+ (lambda (object stream type identity &optional body)
+ (presenting-object object stream
+ (funcall *saved-%print-unreadable-object*
+ object stream type identity body)))))
+ (defmethod print-object :around ((object pathname) stream)
+ (presenting-object object stream
+ (call-next-method))))))
+
+#+allegro
+(progn
+ (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation)
+ (swank::presenting-object object stream (excl:call-next-fwrapper)))
+ (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth)
+ (presenting-object-if (can-present-readable-objects stream) pathname stream
+ (excl:call-next-fwrapper)))
+ (defun monkey-patch-stream-printing ()
+ (excl:fwrap 'excl::print-unreadable-object-1
+ 'print-unreadable-present 'presenting-unreadable-wrapper)
+ (excl:fwrap 'excl::pathname-printer
+ 'print-pathname-present 'presenting-pathname-wrapper)))
+
+#-(or allegro sbcl cmu openmcl)
+(defun monkey-patch-stream-printing ()
+ (values))
+
+;; Hook into SWANK.
+
+(defslimefun init-presentation-streams ()
+ (monkey-patch-stream-printing)
+ ;; FIXME: import/use swank-repl to avoid package qualifier.
+ (setq swank-repl:*send-repl-results-function*
+ 'present-repl-results-via-presentation-streams))
+
+(provide :swank-presentation-streams)
diff --git a/vim/bundle/slimv/slime/contrib/swank-presentations.lisp b/vim/bundle/slimv/slime/contrib/swank-presentations.lisp
new file mode 100644
index 0000000..11326af
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-presentations.lisp
@@ -0,0 +1,246 @@
+;;; swank-presentations.lisp --- imitate LispM's presentations
+;;
+;; Authors: Alan Ruttenberg <alanr-l@mumble.net>
+;; Luke Gorrie <luke@synap.se>
+;; Helmut Eller <heller@common-lisp.net>
+;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+;;
+;; License: This code has been placed in the Public Domain. All warranties
+;; are disclaimed.
+;;
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (swank-require :swank-repl))
+
+;;;; Recording and accessing results of computations
+
+(defvar *record-repl-results* t
+ "Non-nil means that REPL results are saved for later lookup.")
+
+(defvar *object-to-presentation-id*
+ (make-weak-key-hash-table :test 'eq)
+ "Store the mapping of objects to numeric identifiers")
+
+(defvar *presentation-id-to-object*
+ (make-weak-value-hash-table :test 'eql)
+ "Store the mapping of numeric identifiers to objects")
+
+(defun clear-presentation-tables ()
+ (clrhash *object-to-presentation-id*)
+ (clrhash *presentation-id-to-object*))
+
+(defvar *presentation-counter* 0 "identifier counter")
+
+(defvar *nil-surrogate* (make-symbol "nil-surrogate"))
+
+;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the
+;; rest of slime isn't thread safe either), do we really care?
+(defun save-presented-object (object)
+ "Save OBJECT and return the assigned id.
+If OBJECT was saved previously return the old id."
+ (let ((object (if (null object) *nil-surrogate* object)))
+ ;; We store *nil-surrogate* instead of nil, to distinguish it from
+ ;; an object that was garbage collected.
+ (or (gethash object *object-to-presentation-id*)
+ (let ((id (incf *presentation-counter*)))
+ (setf (gethash id *presentation-id-to-object*) object)
+ (setf (gethash object *object-to-presentation-id*) id)
+ id))))
+
+(defslimefun lookup-presented-object (id)
+ "Retrieve the object corresponding to ID.
+The secondary value indicates the absence of an entry."
+ (etypecase id
+ (integer
+ ;;
+ (multiple-value-bind (object foundp)
+ (gethash id *presentation-id-to-object*)
+ (cond
+ ((eql object *nil-surrogate*)
+ ;; A stored nil object
+ (values nil t))
+ ((null object)
+ ;; Object that was replaced by nil in the weak hash table
+ ;; when the object was garbage collected.
+ (values nil nil))
+ (t
+ (values object foundp)))))
+ (cons
+ (dcase id
+ ((:frame-var thread-id frame index)
+ (declare (ignore thread-id)) ; later
+ (handler-case
+ (frame-var-value frame index)
+ (t (condition)
+ (declare (ignore condition))
+ (values nil nil))
+ (:no-error (value)
+ (values value t))))
+ ((:inspected-part part-index)
+ (inspector-nth-part part-index))))))
+
+(defslimefun lookup-presented-object-or-lose (id)
+ "Get the result of the previous REPL evaluation with ID."
+ (multiple-value-bind (object foundp) (lookup-presented-object id)
+ (cond (foundp object)
+ (t (error "Attempt to access unrecorded object (id ~D)." id)))))
+
+(defslimefun lookup-and-save-presented-object-or-lose (id)
+ "Get the object associated with ID and save it in the presentation tables."
+ (let ((obj (lookup-presented-object-or-lose id)))
+ (save-presented-object obj)))
+
+(defslimefun clear-repl-results ()
+ "Forget the results of all previous REPL evaluations."
+ (clear-presentation-tables)
+ t)
+
+(defun present-repl-results (values)
+ ;; Override a function in swank.lisp, so that
+ ;; presentations are associated with every REPL result.
+ (flet ((send (value)
+ (let ((id (and *record-repl-results*
+ (save-presented-object value))))
+ (send-to-emacs `(:presentation-start ,id :repl-result))
+ (send-to-emacs `(:write-string ,(prin1-to-string value)
+ :repl-result))
+ (send-to-emacs `(:presentation-end ,id :repl-result))
+ (send-to-emacs `(:write-string ,(string #\Newline)
+ :repl-result)))))
+ (fresh-line)
+ (finish-output)
+ (if (null values)
+ (send-to-emacs `(:write-string "; No value" :repl-result))
+ (mapc #'send values))))
+
+
+;;;; Presentation menu protocol
+;;
+;; To define a menu for a type of object, define a method
+;; menu-choices-for-presentation on that object type. This function
+;; should return a list of two element lists where the first element is
+;; the name of the menu action and the second is a function that will be
+;; called if the menu is chosen. The function will be called with 3
+;; arguments:
+;;
+;; choice: The string naming the action from above
+;;
+;; object: The object
+;;
+;; id: The presentation id of the object
+;;
+;; You might want append (when (next-method-p) (call-next-method)) to
+;; pick up the Menu actions of superclasses.
+;;
+
+(defvar *presentation-active-menu* nil)
+
+(defun menu-choices-for-presentation-id (id)
+ (multiple-value-bind (ob presentp) (lookup-presented-object id)
+ (cond ((not presentp) 'not-present)
+ (t
+ (let ((menu-and-actions (menu-choices-for-presentation ob)))
+ (setq *presentation-active-menu* (cons id menu-and-actions))
+ (mapcar 'car menu-and-actions))))))
+
+(defun swank-ioify (thing)
+ (cond ((keywordp thing) thing)
+ ((and (symbolp thing)(not (find #\: (symbol-name thing))))
+ (intern (symbol-name thing) 'swank-io-package))
+ ((consp thing) (cons (swank-ioify (car thing))
+ (swank-ioify (cdr thing))))
+ (t thing)))
+
+(defun execute-menu-choice-for-presentation-id (id count item)
+ (let ((ob (lookup-presented-object id)))
+ (assert (equal id (car *presentation-active-menu*)) ()
+ "Bug: Execute menu call for id ~a but menu has id ~a"
+ id (car *presentation-active-menu*))
+ (let ((action (second (nth (1- count) (cdr *presentation-active-menu*)))))
+ (swank-ioify (funcall action item ob id)))))
+
+
+(defgeneric menu-choices-for-presentation (object)
+ (:method (ob) (declare (ignore ob)) nil)) ; default method
+
+;; Pathname
+(defmethod menu-choices-for-presentation ((ob pathname))
+ (let* ((file-exists (ignore-errors (probe-file ob)))
+ (lisp-type (make-pathname :type "lisp"))
+ (source-file (and (not (member (pathname-type ob) '("lisp" "cl")
+ :test 'equal))
+ (let ((source (merge-pathnames lisp-type ob)))
+ (and (ignore-errors (probe-file source))
+ source))))
+ (fasl-file (and file-exists
+ (equal (ignore-errors
+ (namestring
+ (truename
+ (compile-file-pathname
+ (merge-pathnames lisp-type ob)))))
+ (namestring (truename ob))))))
+ (remove nil
+ (list*
+ (and (and file-exists (not fasl-file))
+ (list "Edit this file"
+ (lambda(choice object id)
+ (declare (ignore choice id))
+ (ed-in-emacs (namestring (truename object)))
+ nil)))
+ (and file-exists
+ (list "Dired containing directory"
+ (lambda (choice object id)
+ (declare (ignore choice id))
+ (ed-in-emacs (namestring
+ (truename
+ (merge-pathnames
+ (make-pathname :name "" :type "")
+ object))))
+ nil)))
+ (and fasl-file
+ (list "Load this fasl file"
+ (lambda (choice object id)
+ (declare (ignore choice id object))
+ (load ob)
+ nil)))
+ (and fasl-file
+ (list "Delete this fasl file"
+ (lambda (choice object id)
+ (declare (ignore choice id object))
+ (let ((nt (namestring (truename ob))))
+ (when (y-or-n-p-in-emacs "Delete ~a? " nt)
+ (delete-file nt)))
+ nil)))
+ (and source-file
+ (list "Edit lisp source file"
+ (lambda (choice object id)
+ (declare (ignore choice id object))
+ (ed-in-emacs (namestring (truename source-file)))
+ nil)))
+ (and source-file
+ (list "Load lisp source file"
+ (lambda(choice object id)
+ (declare (ignore choice id object))
+ (load source-file)
+ nil)))
+ (and (next-method-p) (call-next-method))))))
+
+(defmethod menu-choices-for-presentation ((ob function))
+ (list (list "Disassemble"
+ (lambda (choice object id)
+ (declare (ignore choice id))
+ (disassemble object)))))
+
+(defslimefun inspect-presentation (id reset-p)
+ (let ((what (lookup-presented-object-or-lose id)))
+ (when reset-p
+ (reset-inspector))
+ (inspect-object what)))
+
+(defslimefun init-presentations ()
+ ;; FIXME: import/use swank-repl to avoid package qualifier.
+ (setq swank-repl:*send-repl-results-function* 'present-repl-results))
+
+(provide :swank-presentations)
diff --git a/vim/bundle/slimv/slime/contrib/swank-quicklisp.lisp b/vim/bundle/slimv/slime/contrib/swank-quicklisp.lisp
new file mode 100644
index 0000000..3654599
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-quicklisp.lisp
@@ -0,0 +1,17 @@
+;;; swank-quicklisp.lisp -- Quicklisp support
+;;
+;; Authors: Matthew Kennedy <burnsidemk@gmail.com>
+;; License: Public Domain
+;;
+
+(in-package :swank)
+
+(defslimefun list-quicklisp-systems ()
+ "Returns the Quicklisp systems list."
+ (if (member :quicklisp *features*)
+ (let ((ql-dist-name (find-symbol "NAME" "QL-DIST"))
+ (ql-system-list (find-symbol "SYSTEM-LIST" "QL")))
+ (mapcar ql-dist-name (funcall ql-system-list)))
+ (error "Could not find Quicklisp already loaded.")))
+
+(provide :swank-quicklisp)
diff --git a/vim/bundle/slimv/slime/contrib/swank-r6rs.scm b/vim/bundle/slimv/slime/contrib/swank-r6rs.scm
new file mode 100644
index 0000000..4e48050
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-r6rs.scm
@@ -0,0 +1,416 @@
+;; swank-r6rs.sls --- Shareable code between swank-ikarus and swank-larceny
+;;
+;; Licence: public domain
+;; Author: Helmut Eller
+;;
+;; This is a Swank server barely capable enough to process simple eval
+;; requests from Emacs before dying. No fancy features like
+;; backtraces, module redefintion, M-. etc. are implemented. Don't
+;; even think about pc-to-source mapping.
+;;
+;; Despite standard modules, this file uses (swank os) and (swank sys)
+;; which define implementation dependend functionality. There are
+;; multiple modules in this files, which is probably not standardized.
+;;
+
+;; Naive FORMAT implementation which supports: ~a ~s ~d ~x ~c
+(library (swank format)
+ (export format printf fprintf)
+ (import (rnrs))
+
+ (define (format f . args)
+ (call-with-string-output-port
+ (lambda (port) (apply fprintf port f args))))
+
+ (define (printf f . args)
+ (let ((port (current-output-port)))
+ (apply fprintf port f args)
+ (flush-output-port port)))
+
+ (define (fprintf port f . args)
+ (let ((len (string-length f)))
+ (let loop ((i 0) (args args))
+ (cond ((= i len) (assert (null? args)))
+ ((and (char=? (string-ref f i) #\~)
+ (< (+ i 1) len))
+ (dispatch-format (string-ref f (+ i 1)) port (car args))
+ (loop (+ i 2) (cdr args)))
+ (else
+ (put-char port (string-ref f i))
+ (loop (+ i 1) args))))))
+
+ (define (dispatch-format char port arg)
+ (let ((probe (assoc char format-dispatch-table)))
+ (cond (probe ((cdr probe) arg port))
+ (else (error "invalid format char: " char)))))
+
+ (define format-dispatch-table
+ `((#\a . ,display)
+ (#\s . ,write)
+ (#\d . ,(lambda (arg port) (put-string port (number->string arg 10))))
+ (#\x . ,(lambda (arg port) (put-string port (number->string arg 16))))
+ (#\c . ,(lambda (arg port) (put-char port arg))))))
+
+
+;; CL-style restarts to let us continue after errors.
+(library (swank restarts)
+ (export with-simple-restart compute-restarts invoke-restart restart-name
+ write-restart-report)
+ (import (rnrs))
+
+ (define *restarts* '())
+
+ (define-record-type restart
+ (fields name reporter continuation))
+
+ (define (with-simple-restart name reporter thunk)
+ (call/cc
+ (lambda (k)
+ (let ((old-restarts *restarts*)
+ (restart (make-restart name (coerce-to-reporter reporter) k)))
+ (dynamic-wind
+ (lambda () (set! *restarts* (cons restart old-restarts)))
+ thunk
+ (lambda () (set! *restarts* old-restarts)))))))
+
+ (define (compute-restarts) *restarts*)
+
+ (define (invoke-restart restart . args)
+ (apply (restart-continuation restart) args))
+
+ (define (write-restart-report restart port)
+ ((restart-reporter restart) port))
+
+ (define (coerce-to-reporter obj)
+ (cond ((string? obj) (lambda (port) (put-string port obj)))
+ (#t (assert (procedure? obj)) obj)))
+
+ )
+
+;; This module encodes & decodes messages from the wire and queues them.
+(library (swank event-queue)
+ (export make-event-queue wait-for-event enqueue-event
+ read-event write-event)
+ (import (rnrs)
+ (rnrs mutable-pairs)
+ (swank format))
+
+ (define-record-type event-queue
+ (fields (mutable q) wait-fun)
+ (protocol (lambda (init)
+ (lambda (wait-fun)
+ (init '() wait-fun)))))
+
+ (define (wait-for-event q pattern)
+ (or (poll q pattern)
+ (begin
+ ((event-queue-wait-fun q) q)
+ (wait-for-event q pattern))))
+
+ (define (poll q pattern)
+ (let loop ((lag #f)
+ (l (event-queue-q q)))
+ (cond ((null? l) #f)
+ ((event-match? (car l) pattern)
+ (cond (lag
+ (set-cdr! lag (cdr l))
+ (car l))
+ (else
+ (event-queue-q-set! q (cdr l))
+ (car l))))
+ (else (loop l (cdr l))))))
+
+ (define (event-match? event pattern)
+ (cond ((or (number? pattern)
+ (member pattern '(t nil)))
+ (equal? event pattern))
+ ((symbol? pattern) #t)
+ ((pair? pattern)
+ (case (car pattern)
+ ((quote) (equal? event (cadr pattern)))
+ ((or) (exists (lambda (p) (event-match? event p)) (cdr pattern)))
+ (else (and (pair? event)
+ (event-match? (car event) (car pattern))
+ (event-match? (cdr event) (cdr pattern))))))
+ (else (error "Invalid pattern: " pattern))))
+
+ (define (enqueue-event q event)
+ (event-queue-q-set! q
+ (append (event-queue-q q)
+ (list event))))
+
+ (define (write-event event port)
+ (let ((payload (call-with-string-output-port
+ (lambda (port) (write event port)))))
+ (write-length (string-length payload) port)
+ (put-string port payload)
+ (flush-output-port port)))
+
+ (define (write-length len port)
+ (do ((i 24 (- i 4)))
+ ((= i 0))
+ (put-string port
+ (number->string (bitwise-bit-field len (- i 4) i)
+ 16))))
+
+ (define (read-event port)
+ (let* ((header (string-append (get-string-n port 2)
+ (get-string-n port 2)
+ (get-string-n port 2)))
+ (_ (printf "header: ~s\n" header))
+ (len (string->number header 16))
+ (_ (printf "len: ~s\n" len))
+ (payload (get-string-n port len)))
+ (printf "payload: ~s\n" payload)
+ (read (open-string-input-port payload))))
+
+ )
+
+;; Entry points for SLIME commands.
+(library (swank rpc)
+ (export connection-info interactive-eval
+ ;;compile-string-for-emacs
+ throw-to-toplevel sldb-abort
+ operator-arglist buffer-first-change
+ create-repl listener-eval)
+ (import (rnrs)
+ (rnrs eval)
+ (only (rnrs r5rs) scheme-report-environment)
+ (swank os)
+ (swank format)
+ (swank restarts)
+ (swank sys)
+ )
+
+ (define (connection-info . _)
+ `(,@'()
+ :pid ,(getpid)
+ :package (:name ">" :prompt ">")
+ :lisp-implementation (,@'()
+ :name ,(implementation-name)
+ :type "R6RS-Scheme")))
+
+ (define (interactive-eval string)
+ (call-with-values
+ (lambda ()
+ (eval-in-interaction-environment (read-from-string string)))
+ (case-lambda
+ (() "; no value")
+ ((value) (format "~s" value))
+ (values (format "values: ~s" values)))))
+
+ (define (throw-to-toplevel) (invoke-restart-by-name-or-nil 'toplevel))
+
+ (define (sldb-abort) (invoke-restart-by-name-or-nil 'abort))
+
+ (define (invoke-restart-by-name-or-nil name)
+ (let ((r (find (lambda (r) (eq? (restart-name r) name))
+ (compute-restarts))))
+ (if r (invoke-restart r) 'nil)))
+
+ (define (create-repl target)
+ (list "" ""))
+
+ (define (listener-eval string)
+ (call-with-values (lambda () (eval-region string))
+ (lambda values `(:values ,@(map (lambda (v) (format "~s" v)) values)))))
+
+ (define (eval-region string)
+ (let ((sexp (read-from-string string)))
+ (if (eof-object? exp)
+ (values)
+ (eval-in-interaction-environment sexp))))
+
+ (define (read-from-string string)
+ (call-with-port (open-string-input-port string) read))
+
+ (define (operator-arglist . _) 'nil)
+ (define (buffer-first-change . _) 'nil)
+
+ )
+
+;; The server proper. Does the TCP stuff and exception handling.
+(library (swank)
+ (export start-server)
+ (import (rnrs)
+ (rnrs eval)
+ (swank os)
+ (swank format)
+ (swank event-queue)
+ (swank restarts))
+
+ (define-record-type connection
+ (fields in-port out-port event-queue))
+
+ (define (start-server port)
+ (accept-connections (or port 4005) #f))
+
+ (define (start-server/port-file port-file)
+ (accept-connections #f port-file))
+
+ (define (accept-connections port port-file)
+ (let ((sock (make-server-socket port)))
+ (printf "Listening on port: ~s\n" (local-port sock))
+ (when port-file
+ (write-port-file (local-port sock) port-file))
+ (let-values (((in out) (accept sock (latin-1-codec))))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (close-socket sock)
+ (serve in out))
+ (lambda ()
+ (close-port in)
+ (close-port out))))))
+
+ (define (write-port-file port port-file)
+ (call-with-output-file
+ (lambda (file)
+ (write port file))))
+
+ (define (serve in out)
+ (let ((err (current-error-port))
+ (q (make-event-queue
+ (lambda (q)
+ (let ((e (read-event in)))
+ (printf "read: ~s\n" e)
+ (enqueue-event q e))))))
+ (dispatch-loop (make-connection in out q))))
+
+ (define-record-type sldb-state
+ (fields level condition continuation next))
+
+ (define (dispatch-loop conn)
+ (let ((event (wait-for-event (connection-event-queue conn) 'x)))
+ (case (car event)
+ ((:emacs-rex)
+ (with-simple-restart
+ 'toplevel "Return to SLIME's toplevel"
+ (lambda ()
+ (apply emacs-rex conn #f (cdr event)))))
+ (else (error "Unhandled event: ~s" event))))
+ (dispatch-loop conn))
+
+ (define (recover thunk on-error-thunk)
+ (let ((ok #f))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (call-with-values thunk
+ (lambda vals
+ (set! ok #t)
+ (apply values vals))))
+ (lambda ()
+ (unless ok
+ (on-error-thunk))))))
+
+ ;; Couldn't resist to exploit the prefix feature.
+ (define rpc-entries (environment '(prefix (swank rpc) swank:)))
+
+ (define (emacs-rex conn sldb-state form package thread tag)
+ (let ((out (connection-out-port conn)))
+ (recover
+ (lambda ()
+ (with-exception-handler
+ (lambda (condition)
+ (call/cc
+ (lambda (k)
+ (sldb-exception-handler conn condition k sldb-state))))
+ (lambda ()
+ (let ((value (apply (eval (car form) rpc-entries) (cdr form))))
+ (write-event `(:return (:ok ,value) ,tag) out)))))
+ (lambda ()
+ (write-event `(:return (:abort) ,tag) out)))))
+
+ (define (sldb-exception-handler connection condition k sldb-state)
+ (when (serious-condition? condition)
+ (let ((level (if sldb-state (+ (sldb-state-level sldb-state) 1) 1))
+ (out (connection-out-port connection)))
+ (write-event `(:debug 0 ,level ,@(debugger-info condition connection))
+ out)
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (sldb-loop connection
+ (make-sldb-state level condition k sldb-state)))
+ (lambda () (write-event `(:debug-return 0 ,level nil) out))))))
+
+ (define (sldb-loop connection state)
+ (apply emacs-rex connection state
+ (cdr (wait-for-event (connection-event-queue connection)
+ '(':emacs-rex . _))))
+ (sldb-loop connection state))
+
+ (define (debugger-info condition connection)
+ (list `(,(call-with-string-output-port
+ (lambda (port) (print-condition condition port)))
+ ,(format " [type ~s]" (if (record? condition)
+ (record-type-name (record-rtd condition))
+ ))
+ ())
+ (map (lambda (r)
+ (list (format "~a" (restart-name r))
+ (call-with-string-output-port
+ (lambda (port)
+ (write-restart-report r port)))))
+ (compute-restarts))
+ '()
+ '()))
+
+ (define (print-condition obj port)
+ (cond ((condition? obj)
+ (let ((list (simple-conditions obj)))
+ (case (length list)
+ ((0)
+ (display "Compuond condition with zero components" port))
+ ((1)
+ (assert (eq? obj (car list)))
+ (print-simple-condition (car list) port))
+ (else
+ (display "Compound condition:\n" port)
+ (for-each (lambda (c)
+ (display " " port)
+ (print-simple-condition c port)
+ (newline port))
+ list)))))
+ (#t
+ (fprintf port "Non-condition object: ~s" obj))))
+
+ (define (print-simple-condition condition port)
+ (fprintf port "~a" (record-type-name (record-rtd condition)))
+ (case (count-record-fields condition)
+ ((0) #f)
+ ((1)
+ (fprintf port ": ")
+ (do-record-fields condition (lambda (name value) (write value port))))
+ (else
+ (fprintf port ":")
+ (do-record-fields condition (lambda (name value)
+ (fprintf port "\n~a: ~s" name value))))))
+
+ ;; Call FUN with RECORD's rtd and parent rtds.
+ (define (do-record-rtds record fun)
+ (do ((rtd (record-rtd record) (record-type-parent rtd)))
+ ((not rtd))
+ (fun rtd)))
+
+ ;; Call FUN with RECORD's field names and values.
+ (define (do-record-fields record fun)
+ (do-record-rtds
+ record
+ (lambda (rtd)
+ (let* ((names (record-type-field-names rtd))
+ (len (vector-length names)))
+ (do ((i 0 (+ 1 i)))
+ ((= i len))
+ (fun (vector-ref names i) ((record-accessor rtd i) record)))))))
+
+ ;; Return the number of fields in RECORD
+ (define (count-record-fields record)
+ (let ((i 0))
+ (do-record-rtds
+ record (lambda (rtd)
+ (set! i (+ i (vector-length (record-type-field-names rtd))))))
+ i))
+
+ )
diff --git a/vim/bundle/slimv/slime/contrib/swank-repl.lisp b/vim/bundle/slimv/slime/contrib/swank-repl.lisp
new file mode 100644
index 0000000..0bed5f4
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-repl.lisp
@@ -0,0 +1,450 @@
+;;; swank-repl.lisp --- Server side part of the Lisp listener.
+;;
+;; License: public domain
+(in-package swank)
+
+(defpackage swank-repl
+ (:use cl swank/backend)
+ (:export *send-repl-results-function*)
+ (:import-from
+ swank
+
+ *default-worker-thread-bindings*
+
+ *loopback-interface*
+
+ add-hook
+ *connection-closed-hook*
+
+ eval-region
+ with-buffer-syntax
+
+ connection
+ connection.socket-io
+ connection.repl-results
+ connection.user-input
+ connection.user-output
+ connection.user-io
+ connection.trace-output
+ connection.dedicated-output
+ connection.env
+
+ multithreaded-connection
+ mconn.active-threads
+ mconn.repl-thread
+ mconn.auto-flush-thread
+ use-threads-p
+
+ *emacs-connection*
+ default-connection
+ with-connection
+
+ send-to-emacs
+ *communication-style*
+ handle-requests
+ wait-for-event
+ make-tag
+ thread-for-evaluation
+ socket-quest
+
+ authenticate-client
+ encode-message
+
+ auto-flush-loop
+ clear-user-input
+
+ current-thread-id
+ cat
+ with-struct*
+ with-retry-restart
+ with-bindings
+
+ package-string-for-prompt
+ find-external-format-or-lose
+
+ defslimefun
+
+ ;; FIXME: those should be exported from swank-repl only, but how to
+ ;; do that whithout breaking init files?
+ *use-dedicated-output-stream*
+ *dedicated-output-stream-port*
+ *globally-redirect-io*
+
+ ))
+
+(in-package swank-repl)
+
+(defvar *use-dedicated-output-stream* nil
+ "When T swank will attempt to create a second connection to Emacs
+which is used just to send output.")
+
+(defvar *dedicated-output-stream-port* 0
+ "Which port we should use for the dedicated output stream.")
+
+(defvar *dedicated-output-stream-buffering*
+ (if (eq *communication-style* :spawn) t nil)
+ "The buffering scheme that should be used for the output stream.
+Valid values are nil, t, :line")
+
+(defvar *globally-redirect-io* nil
+ "When non-nil globally redirect all standard streams to Emacs.")
+
+(defun open-streams (connection properties)
+ "Return the 5 streams for IO redirection:
+DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
+ (let* ((input-fn
+ (lambda ()
+ (with-connection (connection)
+ (with-simple-restart (abort-read
+ "Abort reading input from Emacs.")
+ (read-user-input-from-emacs)))))
+ (dedicated-output (if *use-dedicated-output-stream*
+ (open-dedicated-output-stream
+ connection
+ (getf properties :coding-system))))
+ (in (make-input-stream input-fn))
+ (out (or dedicated-output
+ (make-output-stream (make-output-function connection))))
+ (io (make-two-way-stream in out))
+ (repl-results (make-output-stream-for-target connection
+ :repl-result)))
+ (typecase connection
+ (multithreaded-connection
+ (setf (mconn.auto-flush-thread connection)
+ (spawn (lambda () (auto-flush-loop out))
+ :name "auto-flush-thread"))))
+ (values dedicated-output in out io repl-results)))
+
+(defun make-output-function (connection)
+ "Create function to send user output to Emacs."
+ (lambda (string)
+ (with-connection (connection)
+ (send-to-emacs `(:write-string ,string)))))
+
+(defun make-output-function-for-target (connection target)
+ "Create a function to send user output to a specific TARGET in Emacs."
+ (lambda (string)
+ (with-connection (connection)
+ (with-simple-restart
+ (abort "Abort sending output to Emacs.")
+ (send-to-emacs `(:write-string ,string ,target))))))
+
+(defun make-output-stream-for-target (connection target)
+ "Create a stream that sends output to a specific TARGET in Emacs."
+ (make-output-stream (make-output-function-for-target connection target)))
+
+(defun open-dedicated-output-stream (connection coding-system)
+ "Open a dedicated output connection to the Emacs on SOCKET-IO.
+Return an output stream suitable for writing program output.
+
+This is an optimized way for Lisp to deliver output to Emacs."
+ (let ((socket (socket-quest *dedicated-output-stream-port* nil))
+ (ef (find-external-format-or-lose coding-system)))
+ (unwind-protect
+ (let ((port (local-port socket)))
+ (encode-message `(:open-dedicated-output-stream ,port
+ ,coding-system)
+ (connection.socket-io connection))
+ (let ((dedicated (accept-connection
+ socket
+ :external-format ef
+ :buffering *dedicated-output-stream-buffering*
+ :timeout 30)))
+ (authenticate-client dedicated)
+ (close-socket socket)
+ (setf socket nil)
+ dedicated))
+ (when socket
+ (close-socket socket)))))
+
+(defmethod thread-for-evaluation ((connection multithreaded-connection)
+ (id (eql :find-existing)))
+ (or (car (mconn.active-threads connection))
+ (find-repl-thread connection)))
+
+(defmethod thread-for-evaluation ((connection multithreaded-connection)
+ (id (eql :repl-thread)))
+ (find-repl-thread connection))
+
+(defun find-repl-thread (connection)
+ (cond ((not (use-threads-p))
+ (current-thread))
+ (t
+ (let ((thread (mconn.repl-thread connection)))
+ (cond ((not thread) nil)
+ ((thread-alive-p thread) thread)
+ (t
+ (setf (mconn.repl-thread connection)
+ (spawn-repl-thread connection "new-repl-thread"))))))))
+
+(defun spawn-repl-thread (connection name)
+ (spawn (lambda ()
+ (with-bindings *default-worker-thread-bindings*
+ (repl-loop connection)))
+ :name name))
+
+(defun repl-loop (connection)
+ (handle-requests connection))
+
+;;;;; Redirection during requests
+;;;
+;;; We always redirect the standard streams to Emacs while evaluating
+;;; an RPC. This is done with simple dynamic bindings.
+
+(defslimefun create-repl (target &key coding-system)
+ (assert (eq target nil))
+ (let ((conn *emacs-connection*))
+ (initialize-streams-for-connection conn `(:coding-system ,coding-system))
+ (with-struct* (connection. @ conn)
+ (setf (@ env)
+ `((*standard-input* . ,(@ user-input))
+ ,@(unless *globally-redirect-io*
+ `((*standard-output* . ,(@ user-output))
+ (*trace-output* . ,(or (@ trace-output) (@ user-output)))
+ (*error-output* . ,(@ user-output))
+ (*debug-io* . ,(@ user-io))
+ (*query-io* . ,(@ user-io))
+ (*terminal-io* . ,(@ user-io))))))
+ (maybe-redirect-global-io conn)
+ (add-hook *connection-closed-hook* 'update-redirection-after-close)
+ (typecase conn
+ (multithreaded-connection
+ (setf (mconn.repl-thread conn)
+ (spawn-repl-thread conn "repl-thread"))))
+ (list (package-name *package*)
+ (package-string-for-prompt *package*)))))
+
+(defun initialize-streams-for-connection (connection properties)
+ (multiple-value-bind (dedicated in out io repl-results)
+ (open-streams connection properties)
+ (setf (connection.dedicated-output connection) dedicated
+ (connection.user-io connection) io
+ (connection.user-output connection) out
+ (connection.user-input connection) in
+ (connection.repl-results connection) repl-results)
+ connection))
+
+(defun read-user-input-from-emacs ()
+ (let ((tag (make-tag)))
+ (force-output)
+ (send-to-emacs `(:read-string ,(current-thread-id) ,tag))
+ (let ((ok nil))
+ (unwind-protect
+ (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
+ (setq ok t))
+ (unless ok
+ (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))
+
+;;;;; Listener eval
+
+(defvar *listener-eval-function* 'repl-eval)
+
+(defvar *listener-saved-value* nil)
+
+(defslimefun listener-save-value (slimefun &rest args)
+ "Apply SLIMEFUN to ARGS and save the value.
+The saved value should be visible to all threads and retrieved via
+LISTENER-GET-VALUE."
+ (setq *listener-saved-value* (apply slimefun args))
+ t)
+
+(defslimefun listener-get-value ()
+ "Get the last value saved by LISTENER-SAVE-VALUE.
+The value should be produced as if it were requested through
+LISTENER-EVAL directly, so that spacial variables *, etc are set."
+ (listener-eval (let ((*package* (find-package :keyword)))
+ (write-to-string '*listener-saved-value*))))
+
+(defslimefun listener-eval (string &key (window-width nil window-width-p))
+ (if window-width-p
+ (let ((*print-right-margin* window-width))
+ (funcall *listener-eval-function* string))
+ (funcall *listener-eval-function* string)))
+
+(defslimefun clear-repl-variables ()
+ (let ((variables '(*** ** * /// // / +++ ++ +)))
+ (loop for variable in variables
+ do (setf (symbol-value variable) nil))))
+
+(defvar *send-repl-results-function* 'send-repl-results-to-emacs)
+
+(defun repl-eval (string)
+ (clear-user-input)
+ (with-buffer-syntax ()
+ (with-retry-restart (:msg "Retry SLIME REPL evaluation request.")
+ (track-package
+ (lambda ()
+ (multiple-value-bind (values last-form) (eval-region string)
+ (setq *** ** ** * * (car values)
+ /// // // / / values
+ +++ ++ ++ + + last-form)
+ (funcall *send-repl-results-function* values))))))
+ nil)
+
+(defun track-package (fun)
+ (let ((p *package*))
+ (unwind-protect (funcall fun)
+ (unless (eq *package* p)
+ (send-to-emacs (list :new-package (package-name *package*)
+ (package-string-for-prompt *package*)))))))
+
+(defun send-repl-results-to-emacs (values)
+ (finish-output)
+ (if (null values)
+ (send-to-emacs `(:write-string "; No value" :repl-result))
+ (dolist (v values)
+ (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
+ :repl-result)))))
+
+(defslimefun redirect-trace-output (target)
+ (setf (connection.trace-output *emacs-connection*)
+ (make-output-stream-for-target *emacs-connection* target))
+ nil)
+
+
+
+;;;; IO to Emacs
+;;;
+;;; This code handles redirection of the standard I/O streams
+;;; (`*standard-output*', etc) into Emacs. The `connection' structure
+;;; contains the appropriate streams, so all we have to do is make the
+;;; right bindings.
+
+;;;;; Global I/O redirection framework
+;;;
+;;; Optionally, the top-level global bindings of the standard streams
+;;; can be assigned to be redirected to Emacs. When Emacs connects we
+;;; redirect the streams into the connection, and they keep going into
+;;; that connection even if more are established. If the connection
+;;; handling the streams closes then another is chosen, or if there
+;;; are no connections then we revert to the original (real) streams.
+;;;
+;;; It is slightly tricky to assign the global values of standard
+;;; streams because they are often shadowed by dynamic bindings. We
+;;; solve this problem by introducing an extra indirection via synonym
+;;; streams, so that *STANDARD-INPUT* is a synonym stream to
+;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
+;;; variables, so they can always be assigned to affect a global
+;;; change.
+
+;;;;; Global redirection setup
+
+(defvar *saved-global-streams* '()
+ "A plist to save and restore redirected stream objects.
+E.g. the value for '*standard-output* holds the stream object
+for *standard-output* before we install our redirection.")
+
+(defun setup-stream-indirection (stream-var &optional stream)
+ "Setup redirection scaffolding for a global stream variable.
+Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
+
+1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
+
+2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
+*STANDARD-INPUT*.
+
+3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
+*CURRENT-STANDARD-INPUT*.
+
+This has the effect of making *CURRENT-STANDARD-INPUT* contain the
+effective global value for *STANDARD-INPUT*. This way we can assign
+the effective global value even when *STANDARD-INPUT* is shadowed by a
+dynamic binding."
+ (let ((current-stream-var (prefixed-var '#:current stream-var))
+ (stream (or stream (symbol-value stream-var))))
+ ;; Save the real stream value for the future.
+ (setf (getf *saved-global-streams* stream-var) stream)
+ ;; Define a new variable for the effective stream.
+ ;; This can be reassigned.
+ (proclaim `(special ,current-stream-var))
+ (set current-stream-var stream)
+ ;; Assign the real binding as a synonym for the current one.
+ (let ((stream (make-synonym-stream current-stream-var)))
+ (set stream-var stream)
+ (set-default-initial-binding stream-var `(quote ,stream)))))
+
+(defun prefixed-var (prefix variable-symbol)
+ "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
+ (let ((basename (subseq (symbol-name variable-symbol) 1)))
+ (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
+
+(defvar *standard-output-streams*
+ '(*standard-output* *error-output* *trace-output*)
+ "The symbols naming standard output streams.")
+
+(defvar *standard-input-streams*
+ '(*standard-input*)
+ "The symbols naming standard input streams.")
+
+(defvar *standard-io-streams*
+ '(*debug-io* *query-io* *terminal-io*)
+ "The symbols naming standard io streams.")
+
+(defun init-global-stream-redirection ()
+ (when *globally-redirect-io*
+ (cond (*saved-global-streams*
+ (warn "Streams already redirected."))
+ (t
+ (mapc #'setup-stream-indirection
+ (append *standard-output-streams*
+ *standard-input-streams*
+ *standard-io-streams*))))))
+
+(defun globally-redirect-io-to-connection (connection)
+ "Set the standard I/O streams to redirect to CONNECTION.
+Assigns *CURRENT-<STREAM>* for all standard streams."
+ (dolist (o *standard-output-streams*)
+ (set (prefixed-var '#:current o)
+ (connection.user-output connection)))
+ ;; FIXME: If we redirect standard input to Emacs then we get the
+ ;; regular Lisp top-level trying to read from our REPL.
+ ;;
+ ;; Perhaps the ideal would be for the real top-level to run in a
+ ;; thread with local bindings for all the standard streams. Failing
+ ;; that we probably would like to inhibit it from reading while
+ ;; Emacs is connected.
+ ;;
+ ;; Meanwhile we just leave *standard-input* alone.
+ #+NIL
+ (dolist (i *standard-input-streams*)
+ (set (prefixed-var '#:current i)
+ (connection.user-input connection)))
+ (dolist (io *standard-io-streams*)
+ (set (prefixed-var '#:current io)
+ (connection.user-io connection))))
+
+(defun revert-global-io-redirection ()
+ "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
+ (dolist (stream-var (append *standard-output-streams*
+ *standard-input-streams*
+ *standard-io-streams*))
+ (set (prefixed-var '#:current stream-var)
+ (getf *saved-global-streams* stream-var))))
+
+;;;;; Global redirection hooks
+
+(defvar *global-stdio-connection* nil
+ "The connection to which standard I/O streams are globally redirected.
+NIL if streams are not globally redirected.")
+
+(defun maybe-redirect-global-io (connection)
+ "Consider globally redirecting to CONNECTION."
+ (when (and *globally-redirect-io* (null *global-stdio-connection*)
+ (connection.user-io connection))
+ (unless *saved-global-streams*
+ (init-global-stream-redirection))
+ (setq *global-stdio-connection* connection)
+ (globally-redirect-io-to-connection connection)))
+
+(defun update-redirection-after-close (closed-connection)
+ "Update redirection after a connection closes."
+ (check-type closed-connection connection)
+ (when (eq *global-stdio-connection* closed-connection)
+ (if (and (default-connection) *globally-redirect-io*)
+ ;; Redirect to another connection.
+ (globally-redirect-io-to-connection (default-connection))
+ ;; No more connections, revert to the real streams.
+ (progn (revert-global-io-redirection)
+ (setq *global-stdio-connection* nil)))))
+
+(provide :swank-repl)
diff --git a/vim/bundle/slimv/slime/contrib/swank-sbcl-exts.lisp b/vim/bundle/slimv/slime/contrib/swank-sbcl-exts.lisp
new file mode 100644
index 0000000..29235cd
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-sbcl-exts.lisp
@@ -0,0 +1,64 @@
+;;; swank-sbcl-exts.lisp --- Misc extensions for SBCL
+;;
+;; Authors: Tobias C. Rittweiler <tcr@freebits.de>
+;;
+;; License: Public Domain
+;;
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (swank-require :swank-arglists))
+
+;; We need to do this so users can place `slime-sbcl-exts' into their
+;; ~/.emacs, and still use any implementation they want.
+#+sbcl
+(progn
+
+;;; Display arglist of instructions.
+;;;
+(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'sb-assem:inst))
+ argument-forms)
+ (flet ((decode-instruction-arglist (instr-name instr-arglist)
+ (let ((decoded-arglist (decode-arglist instr-arglist)))
+ ;; The arglist of INST is (instruction ...INSTR-ARGLIST...).
+ (push 'sb-assem::instruction (arglist.required-args decoded-arglist))
+ (values decoded-arglist
+ (list instr-name)
+ t))))
+ (if (null argument-forms)
+ (call-next-method)
+ (destructuring-bind (instruction &rest args) argument-forms
+ (declare (ignore args))
+ (let* ((instr-name
+ (typecase instruction
+ (arglist-dummy
+ (string-upcase (arglist-dummy.string-representation instruction)))
+ (symbol
+ (string-downcase instruction))))
+ (instr-fn
+ #+#.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem)
+ (sb-assem::inst-emitter-symbol instr-name)
+ #+(and
+ (not #.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem))
+ #.(swank/backend:with-symbol '*assem-instructions* 'sb-assem))
+ (gethash instr-name sb-assem:*assem-instructions*)))
+ (cond ((not instr-fn)
+ (call-next-method))
+ ((functionp instr-fn)
+ (with-available-arglist (arglist) (arglist instr-fn)
+ (decode-instruction-arglist instr-name arglist)))
+ (t
+ (assert (symbolp instr-fn))
+ (with-available-arglist (arglist) (arglist instr-fn)
+ ;; SB-ASSEM:INST invokes a symbolic INSTR-FN with
+ ;; current segment and current vop implicitly.
+ (decode-instruction-arglist instr-name
+ (if (get instr-fn :macro)
+ arglist
+ (cddr arglist)))))))))))
+
+
+) ; PROGN
+
+(provide :swank-sbcl-exts)
diff --git a/vim/bundle/slimv/slime/contrib/swank-snapshot.lisp b/vim/bundle/slimv/slime/contrib/swank-snapshot.lisp
new file mode 100644
index 0000000..8edb789
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-snapshot.lisp
@@ -0,0 +1,67 @@
+
+(defpackage swank-snapshot
+ (:use cl)
+ (:export restore-snapshot save-snapshot background-save-snapshot)
+ (:import-from swank defslimefun))
+(in-package swank-snapshot)
+
+(defslimefun save-snapshot (image-file)
+ (swank/backend:save-image image-file
+ (let ((c swank::*emacs-connection*))
+ (lambda () (resurrect c))))
+ (format nil "Dumped lisp to ~A" image-file))
+
+(defslimefun restore-snapshot (image-file)
+ (let* ((conn swank::*emacs-connection*)
+ (stream (swank::connection.socket-io conn))
+ (clone (swank/backend:dup (swank/backend:socket-fd stream)))
+ (style (swank::connection.communication-style conn))
+ (repl (if (swank::connection.user-io conn) t))
+ (args (list "--swank-fd" (format nil "~d" clone)
+ "--swank-style" (format nil "~s" style)
+ "--swank-repl" (format nil "~s" repl))))
+ (swank::close-connection conn nil nil)
+ (swank/backend:exec-image image-file args)))
+
+(defslimefun background-save-snapshot (image-file)
+ (let ((connection swank::*emacs-connection*))
+ (flet ((complete (success)
+ (let ((swank::*emacs-connection* connection))
+ (swank::background-message
+ "Dumping lisp image ~A ~:[failed!~;succeeded.~]"
+ image-file success)))
+ (awaken ()
+ (resurrect connection)))
+ (swank/backend:background-save-image image-file
+ :restart-function #'awaken
+ :completion-function #'complete)
+ (format nil "Started dumping lisp to ~A..." image-file))))
+
+(in-package :swank)
+
+(defun swank-snapshot::resurrect (old-connection)
+ (setq *log-output* nil)
+ (init-log-output)
+ (clear-event-history)
+ (setq *connections* (delete old-connection *connections*))
+ (format *error-output* "args: ~s~%" (command-line-args))
+ (let* ((fd (read-command-line-arg "--swank-fd"))
+ (style (read-command-line-arg "--swank-style"))
+ (repl (read-command-line-arg "--swank-repl"))
+ (* (format *error-output* "fd=~s style=~s~%" fd style))
+ (stream (make-fd-stream fd nil))
+ (connection (make-connection nil stream style)))
+ (let ((*emacs-connection* connection))
+ (when repl (swank::create-repl nil))
+ (background-message "~A" "Lisp image restored"))
+ (serve-requests connection)
+ (simple-repl)))
+
+(defun read-command-line-arg (name)
+ (let* ((args (command-line-args))
+ (pos (position name args :test #'equal)))
+ (read-from-string (elt args (1+ pos)))))
+
+(in-package :swank-snapshot)
+
+(provide :swank-snapshot)
diff --git a/vim/bundle/slimv/slime/contrib/swank-sprof.lisp b/vim/bundle/slimv/slime/contrib/swank-sprof.lisp
new file mode 100644
index 0000000..675240f
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-sprof.lisp
@@ -0,0 +1,154 @@
+;;; swank-sprof.lisp
+;;
+;; Authors: Juho Snellman
+;;
+;; License: MIT
+;;
+
+(in-package :swank)
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :sb-sprof))
+
+#+sbcl(progn
+
+(defvar *call-graph* nil)
+(defvar *node-numbers* nil)
+(defvar *number-nodes* nil)
+
+(defun frame-name (name)
+ (if (consp name)
+ (case (first name)
+ ((sb-c::xep sb-c::tl-xep
+ sb-c::&more-processor
+ sb-c::top-level-form
+ sb-c::&optional-processor)
+ (second name))
+ (sb-pcl::fast-method
+ (cdr name))
+ ((flet labels lambda)
+ (let* ((in (member :in name)))
+ (if (stringp (cadr in))
+ (append (ldiff name in) (cddr in))
+ name)))
+ (t
+ name))
+ name))
+
+(defun pretty-name (name)
+ (let ((*package* (find-package :common-lisp-user))
+ (*print-right-margin* most-positive-fixnum))
+ (format nil "~S" (frame-name name))))
+
+(defun samples-percent (count)
+ (sb-sprof::samples-percent *call-graph* count))
+
+(defun node-values (node)
+ (values (pretty-name (sb-sprof::node-name node))
+ (samples-percent (sb-sprof::node-count node))
+ (samples-percent (sb-sprof::node-accrued-count node))))
+
+(defun filter-swank-nodes (nodes)
+ (let ((swank-packages (load-time-value
+ (mapcar #'find-package
+ '(swank swank/rpc swank/mop
+ swank/match swank/backend)))))
+ (remove-if (lambda (node)
+ (let ((name (sb-sprof::node-name node)))
+ (and (symbolp name)
+ (member (symbol-package name) swank-packages
+ :test #'eq))))
+ nodes)))
+
+(defun serialize-call-graph (&key exclude-swank)
+ (let ((nodes (sb-sprof::call-graph-flat-nodes *call-graph*)))
+ (when exclude-swank
+ (setf nodes (filter-swank-nodes nodes)))
+ (setf nodes (sort (copy-list nodes) #'>
+ ;; :key #'sb-sprof::node-count)))
+ :key #'sb-sprof::node-accrued-count))
+ (setf *number-nodes* (make-hash-table))
+ (setf *node-numbers* (make-hash-table))
+ (loop for node in nodes
+ for i from 1
+ with total = 0
+ collect (multiple-value-bind (name self cumulative)
+ (node-values node)
+ (setf (gethash node *node-numbers*) i
+ (gethash i *number-nodes*) node)
+ (incf total self)
+ (list i name self cumulative total)) into list
+ finally (return
+ (let ((rest (- 100 total)))
+ (return (append list
+ `((nil "Elsewhere" ,rest nil nil)))))))))
+
+(defslimefun swank-sprof-get-call-graph (&key exclude-swank)
+ (when (setf *call-graph* (sb-sprof:report :type nil))
+ (serialize-call-graph :exclude-swank exclude-swank)))
+
+(defslimefun swank-sprof-expand-node (index)
+ (let* ((node (gethash index *number-nodes*)))
+ (labels ((caller-count (v)
+ (loop for e in (sb-sprof::vertex-edges v) do
+ (when (eq (sb-sprof::edge-vertex e) node)
+ (return-from caller-count (sb-sprof::call-count e))))
+ 0)
+ (serialize-node (node count)
+ (etypecase node
+ (sb-sprof::cycle
+ (list (sb-sprof::cycle-index node)
+ (sb-sprof::cycle-name node)
+ (samples-percent count)))
+ (sb-sprof::node
+ (let ((name (node-values node)))
+ (list (gethash node *node-numbers*)
+ name
+ (samples-percent count)))))))
+ (list :callers (loop for node in
+ (sort (copy-list (sb-sprof::node-callers node)) #'>
+ :key #'caller-count)
+ collect (serialize-node node
+ (caller-count node)))
+ :calls (let ((edges (sort (copy-list (sb-sprof::vertex-edges node))
+ #'>
+ :key #'sb-sprof::call-count)))
+ (loop for edge in edges
+ collect
+ (serialize-node (sb-sprof::edge-vertex edge)
+ (sb-sprof::call-count edge))))))))
+
+(defslimefun swank-sprof-disassemble (index)
+ (let* ((node (gethash index *number-nodes*))
+ (debug-info (sb-sprof::node-debug-info node)))
+ (with-output-to-string (s)
+ (typecase debug-info
+ (sb-impl::code-component
+ (sb-disassem::disassemble-memory (sb-vm::code-instructions debug-info)
+ (sb-vm::%code-code-size debug-info)
+ :stream s))
+ (sb-di::compiled-debug-fun
+ (let ((component (sb-di::compiled-debug-fun-component debug-info)))
+ (sb-disassem::disassemble-code-component component :stream s)))
+ (t `(:error "No disassembly available"))))))
+
+(defslimefun swank-sprof-source-location (index)
+ (let* ((node (gethash index *number-nodes*))
+ (debug-info (sb-sprof::node-debug-info node)))
+ (or (when (typep debug-info 'sb-di::compiled-debug-fun)
+ (let* ((component (sb-di::compiled-debug-fun-component debug-info))
+ (function (sb-kernel::%code-entry-points component)))
+ (when function
+ (find-source-location function))))
+ `(:error "No source location available"))))
+
+(defslimefun swank-sprof-start (&key (mode :cpu))
+ (sb-sprof:start-profiling :mode mode))
+
+(defslimefun swank-sprof-stop ()
+ (sb-sprof:stop-profiling))
+
+)
+
+(provide :swank-sprof)
diff --git a/vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp b/vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp
new file mode 100644
index 0000000..5cf95fd
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp
@@ -0,0 +1,264 @@
+(defpackage :swank-trace-dialog
+ (:use :cl)
+ (:import-from :swank :defslimefun :from-string :to-string)
+ (:export #:clear-trace-tree
+ #:dialog-toggle-trace
+ #:dialog-trace
+ #:dialog-traced-p
+ #:dialog-untrace
+ #:dialog-untrace-all
+ #:inspect-trace-part
+ #:report-partial-tree
+ #:report-specs
+ #:report-total
+ #:report-trace-detail
+ #:report-specs
+ #:trace-format
+ #:still-inside
+ #:exited-non-locally
+ #:*record-backtrace*
+ #:*traces-per-report*
+ #:*dialog-trace-follows-trace*
+ #:find-trace-part
+ #:find-trace))
+
+(in-package :swank-trace-dialog)
+
+(defparameter *record-backtrace* nil
+ "Record a backtrace of the last 20 calls for each trace.
+
+Beware that this may have a drastic performance impact on your
+program.")
+
+(defparameter *traces-per-report* 150
+ "Number of traces to report to emacs in each batch.")
+
+
+;;;; `trace-entry' model
+;;;;
+(defvar *traces* (make-array 1000 :fill-pointer 0
+ :adjustable t))
+
+(defvar *trace-lock* (swank/backend:make-lock :name "swank-trace-dialog lock"))
+
+(defvar *current-trace-by-thread* (make-hash-table))
+
+(defclass trace-entry ()
+ ((id :reader id-of)
+ (children :accessor children-of :initform nil)
+ (backtrace :accessor backtrace-of :initform (when *record-backtrace*
+ (useful-backtrace)))
+
+ (spec :initarg :spec :accessor spec-of
+ :initform (error "must provide a spec"))
+ (args :initarg :args :accessor args-of
+ :initform (error "must provide args"))
+ (parent :initarg :parent :reader parent-of
+ :initform (error "must provide a parent, even if nil"))
+ (retlist :initarg :retlist :accessor retlist-of
+ :initform 'still-inside)))
+
+(defmethod initialize-instance :after ((entry trace-entry) &rest initargs)
+ (declare (ignore initargs))
+ (if (parent-of entry)
+ (nconc (children-of (parent-of entry)) (list entry)))
+ (swank/backend:call-with-lock-held
+ *trace-lock*
+ #'(lambda ()
+ (setf (slot-value entry 'id) (fill-pointer *traces*))
+ (vector-push-extend entry *traces*))))
+
+(defmethod print-object ((entry trace-entry) stream)
+ (print-unreadable-object (entry stream)
+ (format stream "~a: ~a" (id-of entry) (spec-of entry))))
+
+(defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside)))
+
+(defun find-trace (id)
+ (when (<= 0 id (1- (length *traces*)))
+ (aref *traces* id)))
+
+(defun find-trace-part (id part-id type)
+ (let* ((trace (find-trace id))
+ (l (and trace
+ (ecase type
+ (:arg (args-of trace))
+ (:retval (swank::ensure-list (retlist-of trace)))))))
+ (values (nth part-id l)
+ (< part-id (length l)))))
+
+(defun useful-backtrace ()
+ (swank/backend:call-with-debugging-environment
+ #'(lambda ()
+ (loop for i from 0
+ for frame in (swank/backend:compute-backtrace 0 20)
+ collect (list i (swank::frame-to-string frame))))))
+
+(defun current-trace ()
+ (gethash (swank/backend:current-thread) *current-trace-by-thread*))
+
+(defun (setf current-trace) (trace)
+ (setf (gethash (swank/backend:current-thread) *current-trace-by-thread*)
+ trace))
+
+
+;;;; Control of traced specs
+;;;
+(defvar *traced-specs* '())
+
+(defslimefun dialog-trace (spec)
+ (flet ((before-hook (args)
+ (setf (current-trace) (make-instance 'trace-entry
+ :spec spec
+ :args args
+ :parent (current-trace))))
+ (after-hook (retlist)
+ (let ((trace (current-trace)))
+ (when trace
+ ;; the current trace might have been wiped away if the
+ ;; user cleared the tree in the meantime. no biggie,
+ ;; don't do anything.
+ ;;
+ (setf (retlist-of trace) retlist
+ (current-trace) (parent-of trace))))))
+ (when (dialog-traced-p spec)
+ (warn "~a is apparently already traced! Untracing and retracing." spec)
+ (dialog-untrace spec))
+ (swank/backend:wrap spec 'trace-dialog
+ :before #'before-hook
+ :after #'after-hook)
+ (pushnew spec *traced-specs*)
+ (format nil "~a is now traced for trace dialog" spec)))
+
+(defslimefun dialog-untrace (spec)
+ (swank/backend:unwrap spec 'trace-dialog)
+ (setq *traced-specs* (remove spec *traced-specs* :test #'equal))
+ (format nil "~a is now untraced for trace dialog" spec))
+
+(defslimefun dialog-toggle-trace (spec)
+ (if (dialog-traced-p spec)
+ (dialog-untrace spec)
+ (dialog-trace spec)))
+
+(defslimefun dialog-traced-p (spec)
+ (find spec *traced-specs* :test #'equal))
+
+(defslimefun dialog-untrace-all ()
+ (untrace)
+ (mapcar #'dialog-untrace *traced-specs*))
+
+(defparameter *dialog-trace-follows-trace* nil)
+
+(setq swank:*after-toggle-trace-hook*
+ #'(lambda (spec traced-p)
+ (when *dialog-trace-follows-trace*
+ (cond (traced-p
+ (dialog-trace spec)
+ "traced for trace dialog as well")
+ (t
+ (dialog-untrace spec)
+ "untraced for the trace dialog as well")))))
+
+
+;;;; A special kind of trace call
+;;;
+(defun trace-format (format-spec &rest format-args)
+ "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace."
+ (let* ((line (apply #'format nil format-spec format-args)))
+ (make-instance 'trace-entry :spec line
+ :args format-args
+ :parent (current-trace)
+ :retlist nil)))
+
+
+;;;; Reporting to emacs
+;;;
+(defparameter *visitor-idx* 0)
+
+(defparameter *visitor-key* nil)
+
+(defvar *unfinished-traces* '())
+
+(defun describe-trace-for-emacs (trace)
+ `(,(id-of trace)
+ ,(and (parent-of trace) (id-of (parent-of trace)))
+ ,(spec-of trace)
+ ,(loop for arg in (args-of trace)
+ for i from 0
+ collect (list i (swank::to-line arg)))
+ ,(loop for retval in (swank::ensure-list (retlist-of trace))
+ for i from 0
+ collect (list i (swank::to-line retval)))))
+
+(defslimefun report-partial-tree (key)
+ (unless (equal key *visitor-key*)
+ (setq *visitor-idx* 0
+ *visitor-key* key))
+ (let* ((recently-finished
+ (loop with i = 0
+ for trace in *unfinished-traces*
+ while (< i *traces-per-report*)
+ when (completed-p trace)
+ collect trace
+ and do
+ (incf i)
+ (setq *unfinished-traces*
+ (remove trace *unfinished-traces*))))
+ (new (loop for i
+ from (length recently-finished)
+ below *traces-per-report*
+ while (< *visitor-idx* (length *traces*))
+ for trace = (aref *traces* *visitor-idx*)
+ collect trace
+ unless (completed-p trace)
+ do (push trace *unfinished-traces*)
+ do (incf *visitor-idx*))))
+ (list
+ (mapcar #'describe-trace-for-emacs
+ (append recently-finished new))
+ (- (length *traces*) *visitor-idx*)
+ key)))
+
+(defslimefun report-trace-detail (trace-id)
+ (swank::call-with-bindings
+ swank::*inspector-printer-bindings*
+ #'(lambda ()
+ (let ((trace (find-trace trace-id)))
+ (when trace
+ (append
+ (describe-trace-for-emacs trace)
+ (list (backtrace-of trace)
+ (swank::to-line trace))))))))
+
+(defslimefun report-specs ()
+ (sort (copy-list *traced-specs*)
+ #'string<
+ :key #'princ-to-string))
+
+(defslimefun report-total ()
+ (length *traces*))
+
+(defslimefun clear-trace-tree ()
+ (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*)
+ *visitor-key* nil
+ *unfinished-traces* nil)
+ (swank/backend:call-with-lock-held
+ *trace-lock*
+ #'(lambda () (setf (fill-pointer *traces*) 0)))
+ nil)
+
+;; HACK: `swank::*inspector-history*' is unbound by default and needs
+;; a reset in that case so that it won't error `swank::inspect-object'
+;; before any other object is inspected in the slime session.
+;;
+(unless (boundp 'swank::*inspector-history*)
+ (swank::reset-inspector))
+
+(defslimefun inspect-trace-part (trace-id part-id type)
+ (multiple-value-bind (obj found)
+ (find-trace-part trace-id part-id type)
+ (if found
+ (swank::inspect-object obj)
+ (error "No object found with ~a, ~a and ~a" trace-id part-id type))))
+
+(provide :swank-trace-dialog)
diff --git a/vim/bundle/slimv/slime/contrib/swank-util.lisp b/vim/bundle/slimv/slime/contrib/swank-util.lisp
new file mode 100644
index 0000000..72743ba
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-util.lisp
@@ -0,0 +1,63 @@
+;;; swank-util.lisp --- stuff of questionable utility
+;;
+;; License: public domain
+
+(in-package :swank)
+
+(defmacro do-symbols* ((var &optional (package '*package*) result-form)
+ &body body)
+ "Just like do-symbols, but makes sure a symbol is visited only once."
+ (let ((seen-ht (gensym "SEEN-HT")))
+ `(let ((,seen-ht (make-hash-table :test #'eq)))
+ (do-symbols (,var ,package ,result-form)
+ (unless (gethash ,var ,seen-ht)
+ (setf (gethash ,var ,seen-ht) t)
+ (tagbody ,@body))))))
+
+(defun classify-symbol (symbol)
+ "Returns a list of classifiers that classify SYMBOL according to its
+underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special
+variable.) The list may contain the following classification
+keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
+:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
+ (check-type symbol symbol)
+ (flet ((type-specifier-p (s)
+ (or (documentation s 'type)
+ (not (eq (type-specifier-arglist s) :not-available)))))
+ (let (result)
+ (when (boundp symbol) (push (if (constantp symbol)
+ :constant :boundp) result))
+ (when (fboundp symbol) (push :fboundp result))
+ (when (type-specifier-p symbol) (push :typespec result))
+ (when (find-class symbol nil) (push :class result))
+ (when (macro-function symbol) (push :macro result))
+ (when (special-operator-p symbol) (push :special-operator result))
+ (when (find-package symbol) (push :package result))
+ (when (and (fboundp symbol)
+ (typep (ignore-errors (fdefinition symbol))
+ 'generic-function))
+ (push :generic-function result))
+ result)))
+
+(defun symbol-classification-string (symbol)
+ "Return a string in the form -f-c---- where each letter stands for
+boundp fboundp generic-function class macro special-operator package"
+ (let ((letters "bfgctmsp")
+ (result (copy-seq "--------")))
+ (flet ((flip (letter)
+ (setf (char result (position letter letters))
+ letter)))
+ (when (boundp symbol) (flip #\b))
+ (when (fboundp symbol)
+ (flip #\f)
+ (when (typep (ignore-errors (fdefinition symbol))
+ 'generic-function)
+ (flip #\g)))
+ (when (type-specifier-p symbol) (flip #\t))
+ (when (find-class symbol nil) (flip #\c) )
+ (when (macro-function symbol) (flip #\m))
+ (when (special-operator-p symbol) (flip #\s))
+ (when (find-package symbol) (flip #\p))
+ result)))
+
+(provide :swank-util)
diff --git a/vim/bundle/slimv/slime/metering.lisp b/vim/bundle/slimv/slime/metering.lisp
new file mode 100644
index 0000000..b87d280
--- /dev/null
+++ b/vim/bundle/slimv/slime/metering.lisp
@@ -0,0 +1,1213 @@
+;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.; -*-
+;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU>
+
+;;; ****************************************************************
+;;; Metering System ************************************************
+;;; ****************************************************************
+;;;
+;;; The Metering System is a portable Common Lisp code profiling tool.
+;;; It gathers timing and consing statistics for specified functions
+;;; while a program is running.
+;;;
+;;; The Metering System is a combination of
+;;; o the Monitor package written by Chris McConnell
+;;; o the Profile package written by Skef Wholey and Rob MacLachlan
+;;; The two systems were merged and extended by Mark Kantrowitz.
+;;;
+;;; Address: Carnegie Mellon University
+;;; School of Computer Science
+;;; Pittsburgh, PA 15213
+;;;
+;;; This code is in the public domain and is distributed without warranty
+;;; of any kind.
+;;;
+;;; This copy is from SLIME, http://www.common-lisp.net/project/slime/
+;;;
+;;;
+
+;;; ********************************
+;;; Change Log *********************
+;;; ********************************
+;;;
+;;; 26-JUN-90 mk Merged functionality of Monitor and Profile packages.
+;;; 26-JUN-90 mk Now handles both inclusive and exclusive statistics
+;;; with respect to nested calls. (Allows it to subtract
+;;; total monitoring overhead for each function, not just
+;;; the time spent monitoring the function itself.)
+;;; 26-JUN-90 mk The table is now saved so that one may manipulate
+;;; the data (sorting it, etc.) even after the original
+;;; source of the data has been cleared.
+;;; 25-SEP-90 mk Added get-cons functions for Lucid 3.0, MACL 1.3.2
+;;; required-arguments functions for Lucid 3.0,
+;;; Franz Allegro CL, and MACL 1.3.2.
+;;; 25-JAN-91 mk Now uses fdefinition if available.
+;;; 25-JAN-91 mk Replaced (and :allegro (not :coral)) with :excl.
+;;; Much better solution for the fact that both call
+;;; themselves :allegro.
+;;; 5-JUL-91 mk Fixed warning to occur only when file is loaded
+;;; uncompiled.
+;;; 5-JUL-91 mk When many unmonitored functions, print out number
+;;; instead of whole list.
+;;; 24-MAR-92 mk Updated for CLtL2 compatibility. space measuring
+;;; doesn't work in MCL, but fixed so that timing
+;;; statistics do.
+;;; 26-MAR-92 mk Updated for Lispworks. Replaced :ccl with
+;;; (and :ccl (not :lispworks)).
+;;; 27-MAR-92 mk Added get-cons for Allegro-V4.0.
+;;; 01-JAN-93 mk v2.0 Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1,
+;;; Lucid 4.0, ibcl
+;;; 25-JAN-94 mk v2.1 Patches for CLISP from Bruno Haible.
+;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL.
+;;; Purely to cut down on stale code (e.g. #+cltl2) in this
+;;; version that is bundled with SLIME.
+;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL.
+;;; 07-Aug-12 heller Break lines at 80 columns
+;;;
+
+;;; ********************************
+;;; To Do **************************
+;;; ********************************
+;;;
+;;; - Need get-cons for Allegro, AKCL.
+;;; - Speed up monitoring code. Replace use of hash tables with an embedded
+;;; offset in an array so that it will be faster than using gethash.
+;;; (i.e., svref/closure reference is usually faster than gethash).
+;;; - Beware of (get-internal-run-time) overflowing. Yikes!
+;;; - Check robustness with respect to profiled functions.
+;;; - Check logic of computing inclusive and exclusive time and consing.
+;;; Especially wrt incf/setf comment below. Should be incf, so we
+;;; sum recursive calls.
+;;; - Add option to record caller statistics -- this would list who
+;;; called which functions and how often.
+;;; - switches to turn timing/CONSING statistics collection on/off.
+
+
+;;; ********************************
+;;; Notes **************************
+;;; ********************************
+;;;
+;;; METERING has been tested (successfully) in the following lisps:
+;;; CMU Common Lisp (16d, Python Compiler 1.0 ) :new-compiler
+;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
+;;; Macintosh Allegro Common Lisp (1.3.2)
+;;; Macintosh Common Lisp (2.0)
+;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 11/19/90) :allegro-v3.1
+;;; ExCL (Franz Allegro CL 4.0.1 [Sun4] 2/8/91) :allegro-v4.0
+;;; ExCL (Franz Allegro CL 4.1 [SPARC R1] 8/28/92 14:06) :allegro-v4.1
+;;; ExCL (Franz ACL 5.0.1 [Linux/X86] 6/29/99 16:11) :allegro-v5.0.1
+;;; Lucid CL (Version 2.1 6-DEC-87)
+;;; Lucid Common Lisp (3.0)
+;;; Lucid Common Lisp (4.0.1 HP-700 12-Aug-91)
+;;; AKCL (1.86, June 30, 1987 or later)
+;;; Ibuki Common Lisp (Version 2, release 01.027)
+;;; CLISP (January 1994)
+;;;
+;;; METERING needs to be tested in the following lisps:
+;;; Symbolics Common Lisp (8.0)
+;;; KCL (June 3, 1987 or later)
+;;; TI (Release 4.1 or later)
+;;; Golden Common Lisp (3.1 IBM-PC)
+;;; VAXLisp (2.0, 3.1)
+;;; Procyon Common Lisp
+
+
+;;; ****************************************************************
+;;; Documentation **************************************************
+;;; ****************************************************************
+;;;
+;;; This system runs in any valid Common Lisp. Four small
+;;; implementation-dependent changes can be made to improve performance
+;;; and prettiness. In the section labelled "Implementation Dependent
+;;; Changes" below, you should tailor the functions REQUIRED-ARGUMENTS,
+;;; GET-CONS, GET-TIME, and TIME-UNITS-PER-SECOND to your implementation
+;;; for the best results. If GET-CONS is not specified for your
+;;; implementation, no consing information will be reported. The other
+;;; functions will default to working forms, albeit inefficient, in
+;;; non-CMU implementations. If you tailor these functions for a particular
+;;; version of Common Lisp, we'd appreciate receiving the code.
+;;;
+
+;;; ****************************************************************
+;;; Usage Notes ****************************************************
+;;; ****************************************************************
+;;;
+;;; SUGGESTED USAGE:
+;;;
+;;; Start by monitoring big pieces of the program, then carefully choose
+;;; which functions close to, but not in, the inner loop are to be
+;;; monitored next. Don't monitor functions that are called by other
+;;; monitored functions: you will only confuse yourself.
+;;;
+;;; If the per-call time reported is less than 1/10th of a second, then
+;;; consider the clock resolution and profiling overhead before you believe
+;;; the time. It may be that you will need to run your program many times
+;;; in order to average out to a higher resolution.
+;;;
+;;; The easiest way to use this package is to load it and execute either
+;;; (swank-monitor:with-monitoring (names*) ()
+;;; your-forms*)
+;;; or
+;;; (swank-monitor:monitor-form your-form)
+;;; The former allows you to specify which functions will be monitored; the
+;;; latter monitors all functions in the current package. Both automatically
+;;; produce a table of statistics. Other variants can be constructed from
+;;; the monitoring primitives, which are described below, along with a
+;;; fuller description of these two macros.
+;;;
+;;; For best results, compile this file before using.
+;;;
+;;;
+;;; CLOCK RESOLUTION:
+;;;
+;;; Unless you are very lucky, the length of your machine's clock "tick" is
+;;; probably much longer than the time it takes a simple function to run.
+;;; For example, on the IBM RT, the clock resolution is 1/50th of a second.
+;;; This means that if a function is only called a few times, then only the
+;;; first couple of decimal places are really meaningful.
+;;;
+;;;
+;;; MONITORING OVERHEAD:
+;;;
+;;; The added monitoring code takes time to run every time that the monitored
+;;; function is called, which can disrupt the attempt to collect timing
+;;; information. In order to avoid serious inflation of the times for functions
+;;; that take little time to run, an estimate of the overhead due to monitoring
+;;; is subtracted from the times reported for each function.
+;;;
+;;; Although this correction works fairly well, it is not totally accurate,
+;;; resulting in times that become increasingly meaningless for functions
+;;; with short runtimes. For example, subtracting the estimated overhead
+;;; may result in negative times for some functions. This is only a concern
+;;; when the estimated profiling overhead is many times larger than
+;;; reported total CPU time.
+;;;
+;;; If you monitor functions that are called by monitored functions, in
+;;; :inclusive mode the monitoring overhead for the inner function is
+;;; subtracted from the CPU time for the outer function. [We do this by
+;;; counting for each function not only the number of calls to *this*
+;;; function, but also the number of monitored calls while it was running.]
+;;; In :exclusive mode this is not necessary, since we subtract the
+;;; monitoring time of inner functions, overhead & all.
+;;;
+;;; Otherwise, the estimated monitoring overhead is not represented in the
+;;; reported total CPU time. The sum of total CPU time and the estimated
+;;; monitoring overhead should be close to the total CPU time for the
+;;; entire monitoring run (as determined by TIME).
+;;;
+;;; A timing overhead factor is computed at load time. This will be incorrect
+;;; if the monitoring code is run in a different environment than this file
+;;; was loaded in. For example, saving a core image on a high performance
+;;; machine and running it on a low performance one will result in the use
+;;; of an erroneously small overhead factor.
+;;;
+;;;
+;;; If your times vary widely, possible causes are:
+;;; - Garbage collection. Try turning it off, then running your code.
+;;; Be warned that monitoring code will probably cons when it does
+;;; (get-internal-run-time).
+;;; - Swapping. If you have enough memory, execute your form once
+;;; before monitoring so that it will be swapped into memory. Otherwise,
+;;; get a bigger machine!
+;;; - Resolution of internal-time-units-per-second. If this value is
+;;; too low, then the timings become wild. You can try executing more
+;;; of whatever your test is, but that will only work if some of your
+;;; paths do not match the timer resolution.
+;;; internal-time-units-per-second is so coarse -- on a Symbolics it is
+;;; 977, in MACL it is 60.
+;;;
+;;;
+
+;;; ****************************************************************
+;;; Interface ******************************************************
+;;; ****************************************************************
+;;;
+;;; WITH-MONITORING (&rest functions) [Macro]
+;;; (&optional (nested :exclusive)
+;;; (threshold 0.01)
+;;; (key :percent-time))
+;;; &body body
+;;; The named functions will be set up for monitoring, the body forms executed,
+;;; a table of results printed, and the functions unmonitored. The nested,
+;;; threshold, and key arguments are passed to report-monitoring below.
+;;;
+;;; MONITOR-FORM form [Macro]
+;;; &optional (nested :exclusive)
+;;; (threshold 0.01)
+;;; (key :percent-time)
+;;; All functions in the current package are set up for monitoring while
+;;; the form is executed, and automatically unmonitored after a table of
+;;; results has been printed. The nested, threshold, and key arguments
+;;; are passed to report-monitoring below.
+;;;
+;;; *MONITORED-FUNCTIONS* [Variable]
+;;; This holds a list of all functions that are currently being monitored.
+;;;
+;;; MONITOR &rest names [Macro]
+;;; The named functions will be set up for monitoring by augmenting
+;;; their function definitions with code that gathers statistical information
+;;; about code performance. As with the TRACE macro, the function names are
+;;; not evaluated. Calls the function SWANK-MONITOR::MONITORING-ENCAPSULATE on each
+;;; function name. If no names are specified, returns a list of all
+;;; monitored functions.
+;;;
+;;; If name is not a symbol, it is evaled to return the appropriate
+;;; closure. This allows you to monitor closures stored anywhere like
+;;; in a variable, array or structure. Most other monitoring packages
+;;; can't handle this.
+;;;
+;;; MONITOR-ALL &optional (package *package*) [Function]
+;;; Monitors all functions in the specified package, which defaults to
+;;; the current package.
+;;;
+;;; UNMONITOR &rest names [Macro]
+;;; Removes monitoring code from the named functions. If no names are
+;;; specified, all currently monitored functions are unmonitored.
+;;;
+;;; RESET-MONITORING-INFO name [Function]
+;;; Resets the monitoring statistics for the specified function.
+;;;
+;;; RESET-ALL-MONITORING [Function]
+;;; Resets the monitoring statistics for all monitored functions.
+;;;
+;;; MONITORED name [Function]
+;;; Predicate to test whether a function is monitored.
+;;;
+;;; REPORT-MONITORING &optional names [Function]
+;;; (nested :exclusive)
+;;; (threshold 0.01)
+;;; (key :percent-time)
+;;; Creates a table of monitoring information for the specified list
+;;; of names, and displays the table using display-monitoring-results.
+;;; If names is :all or nil, uses all currently monitored functions.
+;;; Takes the following arguments:
+;;; - NESTED specifies whether nested calls of monitored functions
+;;; are included in the times for monitored functions.
+;;; o If :inclusive, the per-function information is for the entire
+;;; duration of the monitored function, including any calls to
+;;; other monitored functions. If functions A and B are monitored,
+;;; and A calls B, then the accumulated time and consing for A will
+;;; include the time and consing of B. Note: if a function calls
+;;; itself recursively, the time spent in the inner call(s) may
+;;; be counted several times.
+;;; o If :exclusive, the information excludes time attributed to
+;;; calls to other monitored functions. This is the default.
+;;; - THRESHOLD specifies that only functions which have been executed
+;;; more than threshold percent of the time will be reported. Defaults
+;;; to 1%. If a threshold of 0 is specified, all functions are listed,
+;;; even those with 0 or negative running times (see note on overhead).
+;;; - KEY specifies that the table be sorted by one of the following
+;;; sort keys:
+;;; :function alphabetically by function name
+;;; :percent-time by percent of total execution time
+;;; :percent-cons by percent of total consing
+;;; :calls by number of times the function was called
+;;; :time-per-call by average execution time per function
+;;; :cons-per-call by average consing per function
+;;; :time same as :percent-time
+;;; :cons same as :percent-cons
+;;;
+;;; REPORT &key (names :all) [Function]
+;;; (nested :exclusive)
+;;; (threshold 0.01)
+;;; (sort-key :percent-time)
+;;; (ignore-no-calls nil)
+;;;
+;;; Same as REPORT-MONITORING but we use a nicer keyword interface.
+;;;
+;;; DISPLAY-MONITORING-RESULTS &optional (threshold 0.01) [Function]
+;;; (key :percent-time)
+;;; Prints a table showing for each named function:
+;;; - the total CPU time used in that function for all calls
+;;; - the total number of bytes consed in that function for all calls
+;;; - the total number of calls
+;;; - the average amount of CPU time per call
+;;; - the average amount of consing per call
+;;; - the percent of total execution time spent executing that function
+;;; - the percent of total consing spent consing in that function
+;;; Summary totals of the CPU time, consing, and calls columns are printed.
+;;; An estimate of the monitoring overhead is also printed. May be run
+;;; even after unmonitoring all the functions, to play with the data.
+;;;
+;;; SAMPLE TABLE:
+#|
+ Cons
+ % % Per Total Total
+Function Time Cons Calls Sec/Call Call Time Cons
+----------------------------------------------------------------------
+FIND-ROLE: 0.58 0.00 136 0.003521 0 0.478863 0
+GROUP-ROLE: 0.35 0.00 365 0.000802 0 0.292760 0
+GROUP-PROJECTOR: 0.05 0.00 102 0.000408 0 0.041648 0
+FEATURE-P: 0.02 0.00 570 0.000028 0 0.015680 0
+----------------------------------------------------------------------
+TOTAL: 1173 0.828950 0
+Estimated total monitoring overhead: 0.88 seconds
+|#
+
+;;; ****************************************************************
+;;; METERING *******************************************************
+;;; ****************************************************************
+
+;;; ********************************
+;;; Warn people using the wrong Lisp
+;;; ********************************
+
+#-(or clisp openmcl)
+(warn "metering.lisp does not support your Lisp implementation!")
+
+;;; ********************************
+;;; Packages ***********************
+;;; ********************************
+
+;;; For CLtL2 compatible lisps
+
+(defpackage "SWANK-MONITOR" (:use "COMMON-LISP")
+ (:export "*MONITORED-FUNCTIONS*"
+ "MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM"
+ "WITH-MONITORING"
+ "RESET-MONITORING-INFO" "RESET-ALL-MONITORING"
+ "MONITORED"
+ "REPORT-MONITORING"
+ "DISPLAY-MONITORING-RESULTS"
+ "MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE"
+ "REPORT"))
+(in-package "SWANK-MONITOR")
+
+;;; Warn user if they're loading the source instead of compiling it first.
+(eval-when (eval)
+ (warn "This file should be compiled before loading for best results."))
+
+;;; ********************************
+;;; Version ************************
+;;; ********************************
+
+(defparameter *metering-version* "v2.1 25-JAN-94"
+ "Current version number/date for Metering.")
+
+
+;;; ****************************************************************
+;;; Implementation Dependent Definitions ***************************
+;;; ****************************************************************
+
+;;; ********************************
+;;; Timing Functions ***************
+;;; ********************************
+;;; The get-time function is called to find the total number of ticks since
+;;; the beginning of time. time-units-per-second allows us to convert units
+;;; to seconds.
+
+#-(or clisp openmcl)
+(eval-when (compile eval)
+ (warn
+ "You may want to supply implementation-specific get-time functions."))
+
+(defconstant time-units-per-second internal-time-units-per-second)
+
+#+openmcl
+(progn
+ (deftype time-type () 'unsigned-byte)
+ (deftype consing-type () 'unsigned-byte))
+
+(defmacro get-time ()
+ `(the time-type (get-internal-run-time)))
+
+;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of
+;;; milliseconds spent during GC. We could subtract this from
+;;; the value returned by get-internal-run-time to eliminate
+;;; the effect of GC on the timing values, but we prefer to let
+;;; the user run without GC on. If the application is so big that
+;;; it requires GC to complete, then the GC times are part of the
+;;; cost of doing business, and will average out in the long run.
+;;; If it seems really important to a user that GC times not be
+;;; counted, then uncomment the following three lines and read-time
+;;; conditionalize the definition of get-time above with #-:openmcl.
+;#+openmcl
+;(defmacro get-time ()
+; `(the time-type (- (get-internal-run-time) (ccl:gctime))))
+
+;;; ********************************
+;;; Consing Functions **************
+;;; ********************************
+;;; The get-cons macro is called to find the total number of bytes
+;;; consed since the beginning of time.
+
+#+clisp
+(defun get-cons ()
+ (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)
+ (sys::%%time)
+ (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
+ (dpb space1 (byte 24 24) space2)))
+
+;;; Macintosh Common Lisp 2.0
+;;; Note that this includes bytes that were allocated during GC.
+;;; We could subtract this out by advising GC like we did under
+;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't
+;;; run without GC, then the bytes consed during GC are a cost of
+;;; running their program. Metering the code a few times will
+;;; avoid the consing values being too lopsided. If a user really really
+;;; wants to subtract out the consing during GC, replace the following
+;;; two lines with the commented out code.
+#+openmcl
+(defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated)))
+
+#-(or clisp openmcl)
+(progn
+ (eval-when (compile eval)
+ (warn "No consing will be reported unless a get-cons function is ~
+ defined."))
+
+ (defmacro get-cons () '(the consing-type 0)))
+
+;; actually, neither `get-cons' nor `get-time' are used as is,
+;; but only in the following macro `with-time/cons'
+#-:clisp
+(defmacro with-time/cons ((delta-time delta-cons) form &body post-process)
+ (let ((start-cons (gensym "START-CONS-"))
+ (start-time (gensym "START-TIME-")))
+ `(let ((,start-time (get-time)) (,start-cons (get-cons)))
+ (declare (type time-type ,start-time)
+ (type consing-type ,start-cons))
+ (multiple-value-prog1 ,form
+ (let ((,delta-time (- (get-time) ,start-time))
+ (,delta-cons (- (get-cons) ,start-cons)))
+ ,@post-process)))))
+
+#+clisp
+(progn
+ (defmacro delta4 (nv1 nv2 ov1 ov2 by)
+ `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2))
+
+ (let ((del (find-symbol "DELTA4" "SYS")))
+ (when del (setf (fdefinition 'delta4) (fdefinition del))))
+
+ (if (< internal-time-units-per-second 1000000)
+ ;; TIME_1: AMIGA, OS/2, UNIX_TIMES
+ (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
+ `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16))
+ ;; TIME_2: other UNIX, WIN32
+ (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
+ `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second)
+ (- ,new-time2 ,old-time2))))
+
+ (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2)
+ `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24))
+
+ ;; avoid consing: when the application conses a lot,
+ ;; get-cons may return a bignum, so we really should not use it.
+ (defmacro with-time/cons ((delta-time delta-cons) form &body post-process)
+ (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-"))
+ (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-"))
+ (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-"))
+ (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-"))
+ (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym)))
+ `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2
+ ,gc1 ,gc2 ,beg-cons1 ,beg-cons2)
+ (sys::%%time)
+ (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
+ (multiple-value-prog1 ,form
+ (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2
+ ,gc1 ,gc2 ,end-cons1 ,end-cons2)
+ (sys::%%time)
+ (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
+ (let ((,delta-time (delta4-time ,end-time1 ,end-time2
+ ,beg-time1 ,beg-time2))
+ (,delta-cons (delta4-cons ,end-cons1 ,end-cons2
+ ,beg-cons1 ,beg-cons2)))
+ ,@post-process)))))))
+
+;;; ********************************
+;;; Required Arguments *************
+;;; ********************************
+;;;
+;;; Required (Fixed) vs Optional Args
+;;;
+;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
+;;; number of required arguments, and use &rest to capture only non-required
+;;; arguments. The function Required-Arguments returns two values: the first
+;;; is the number of required arguments, and the second is T iff there are any
+;;; non-required arguments (e.g. &optional, &rest, &key).
+
+;;; Lucid, Allegro, and Macintosh Common Lisp
+#+openmcl
+(defun required-arguments (name)
+ (let* ((function (symbol-function name))
+ (args (ccl:arglist function))
+ (pos (position-if #'(lambda (x)
+ (and (symbolp x)
+ (let ((name (symbol-name x)))
+ (and (>= (length name) 1)
+ (char= (schar name 0)
+ #\&)))))
+ args)))
+ (if pos
+ (values pos t)
+ (values (length args) nil))))
+
+#+clisp
+(defun required-arguments (name)
+ (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p)
+ (sys::function-signature name t)
+ (if name ; no error
+ (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p))
+ (values 0 t))))
+
+#-(or clisp openmcl)
+(progn
+ (eval-when (compile eval)
+ (warn
+ "You may want to add an implementation-specific ~
+Required-Arguments function."))
+ (eval-when (load eval)
+ (defun required-arguments (name)
+ (declare (ignore name))
+ (values 0 t))))
+
+#|
+;;;Examples
+(defun square (x) (* x x))
+(defun square2 (x &optional y) (* x x y))
+(defun test (x y &optional (z 3)) 3)
+(defun test2 (x y &optional (z 3) &rest fred) 3)
+
+(required-arguments 'square) => 1 nil
+(required-arguments 'square2) => 1 t
+(required-arguments 'test) => 2 t
+(required-arguments 'test2) => 2 t
+|#
+
+
+;;; ****************************************************************
+;;; Main METERING Code *********************************************
+;;; ****************************************************************
+
+;;; ********************************
+;;; Global Variables ***************
+;;; ********************************
+(defvar *MONITOR-TIME-OVERHEAD* nil
+ "The amount of time an empty monitored function costs.")
+(defvar *MONITOR-CONS-OVERHEAD* nil
+ "The amount of cons an empty monitored function costs.")
+
+(defvar *TOTAL-TIME* 0
+ "Total amount of time monitored so far.")
+(defvar *TOTAL-CONS* 0
+ "Total amount of consing monitored so far.")
+(defvar *TOTAL-CALLS* 0
+ "Total number of calls monitored so far.")
+(proclaim '(type time-type *total-time*))
+(proclaim '(type consing-type *total-cons*))
+(proclaim '(fixnum *total-calls*))
+
+;;; ********************************
+;;; Accessor Functions *************
+;;; ********************************
+;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables
+;;; containing closures.
+(defmacro PLACE-FUNCTION (function-place)
+ "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE
+if it isn't a symbol, to allow monitoring of closures located in
+variables/arrays/structures."
+ ;; Note that (fboundp 'fdefinition) returns T even if fdefinition
+ ;; is a macro, which is what we want.
+ (if (fboundp 'fdefinition)
+ `(if (fboundp ,function-place)
+ (fdefinition ,function-place)
+ (eval ,function-place))
+ `(if (symbolp ,function-place)
+ (symbol-function ,function-place)
+ (eval ,function-place))))
+
+(defsetf PLACE-FUNCTION (function-place) (function)
+ "Set the function in FUNCTION-PLACE to FUNCTION."
+ (if (fboundp 'fdefinition)
+ ;; If we're conforming to CLtL2, use fdefinition here.
+ `(if (fboundp ,function-place)
+ (setf (fdefinition ,function-place) ,function)
+ (eval '(setf ,function-place ',function)))
+ `(if (symbolp ,function-place)
+ (setf (symbol-function ,function-place) ,function)
+ (eval '(setf ,function-place ',function)))))
+
+#|
+;;; before using fdefinition
+(defun PLACE-FUNCTION (function-place)
+ "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE
+if it isn't a symbol, to allow monitoring of closures located in
+variables/arrays/structures."
+ (if (symbolp function-place)
+ (symbol-function function-place)
+ (eval function-place)))
+
+(defsetf PLACE-FUNCTION (function-place) (function)
+ "Set the function in FUNCTION-PLACE to FUNCTION."
+ `(if (symbolp ,function-place)
+ (setf (symbol-function ,function-place) ,function)
+ (eval '(setf ,function-place ',function))))
+|#
+
+(defun PLACE-FBOUNDP (function-place)
+ "Test to see if FUNCTION-PLACE is a function."
+ ;; probably should be
+ #|(or (and (symbolp function-place)(fboundp function-place))
+ (functionp (place-function function-place)))|#
+ (if (symbolp function-place)
+ (fboundp function-place)
+ (functionp (place-function function-place))))
+
+(defun PLACE-MACROP (function-place)
+ "Test to see if FUNCTION-PLACE is a macro."
+ (when (symbolp function-place)
+ (macro-function function-place)))
+
+;;; ********************************
+;;; Measurement Tables *************
+;;; ********************************
+(defvar *monitored-functions* nil
+ "List of monitored symbols.")
+
+;;; We associate a METERING-FUNCTIONS structure with each monitored function
+;;; name or other closure. This holds the functions that we call to manipulate
+;;; the closure which implements the encapsulation.
+;;;
+(defstruct metering-functions
+ (name nil)
+ (old-definition nil :type function)
+ (new-definition nil :type function)
+ (read-metering nil :type function)
+ (reset-metering nil :type function))
+
+;;; In general using hash tables in time-critical programs is a bad idea,
+;;; because when one has to grow the table and rehash everything, the
+;;; timing becomes grossly inaccurate. In this case it is not an issue
+;;; because all inserting of entries in the hash table occurs before the
+;;; timing commences. The only circumstance in which this could be a
+;;; problem is if the lisp rehashes on the next reference to the table,
+;;; instead of when the entry which forces a rehash was inserted.
+;;;
+;;; Note that a similar kind of problem can occur with GC, which is why
+;;; one should turn off GC when monitoring code.
+;;;
+(defvar *monitor* (make-hash-table :test #'equal)
+ "Hash table in which METERING-FUNCTIONS structures are stored.")
+(defun get-monitor-info (name)
+ (gethash name *monitor*))
+(defsetf get-monitor-info (name) (info)
+ `(setf (gethash ,name *monitor*) ,info))
+
+(defun MONITORED (function-place)
+ "Test to see if a FUNCTION-PLACE is monitored."
+ (and (place-fboundp function-place) ; this line necessary?
+ (get-monitor-info function-place)))
+
+(defun reset-monitoring-info (name)
+ "Reset the monitoring info for the specified function."
+ (let ((finfo (get-monitor-info name)))
+ (when finfo
+ (funcall (metering-functions-reset-metering finfo)))))
+(defun reset-all-monitoring ()
+ "Reset monitoring info for all functions."
+ (setq *total-time* 0
+ *total-cons* 0
+ *total-calls* 0)
+ (dolist (symbol *monitored-functions*)
+ (when (monitored symbol)
+ (reset-monitoring-info symbol))))
+
+(defun monitor-info-values (name &optional (nested :exclusive) warn)
+ "Returns monitoring information values for the named function,
+adjusted for overhead."
+ (let ((finfo (get-monitor-info name)))
+ (if finfo
+ (multiple-value-bind (inclusive-time inclusive-cons
+ exclusive-time exclusive-cons
+ calls nested-calls)
+ (funcall (metering-functions-read-metering finfo))
+ (unless (or (null warn)
+ (eq (place-function name)
+ (metering-functions-new-definition finfo)))
+ (warn "Funtion ~S has been redefined, so times may be inaccurate.~@
+ MONITOR it again to record calls to the new definition."
+ name))
+ (case nested
+ (:exclusive (values calls
+ nested-calls
+ (- exclusive-time
+ (* calls *monitor-time-overhead*))
+ (- exclusive-cons
+ (* calls *monitor-cons-overhead*))))
+ ;; In :inclusive mode, subtract overhead for all the
+ ;; called functions as well. Nested-calls includes the
+ ;; calls of the function as well. [Necessary 'cause of
+ ;; functions which call themselves recursively.]
+ (:inclusive (values calls
+ nested-calls
+ (- inclusive-time
+ (* nested-calls ;(+ calls)
+ *monitor-time-overhead*))
+ (- inclusive-cons
+ (* nested-calls ;(+ calls)
+ *monitor-cons-overhead*))))))
+ (values 0 0 0 0))))
+
+;;; ********************************
+;;; Encapsulate ********************
+;;; ********************************
+(eval-when (compile load eval)
+;; Returns a lambda expression for a function that, when called with the
+;; function name, will set up that function for metering.
+;;
+;; A function is monitored by replacing its definition with a closure
+;; created by the following function. The closure records the monitoring
+;; data, and updates the data with each call of the function.
+;;
+;; Other closures are used to read and reset the data.
+(defun make-monitoring-encapsulation (min-args optionals-p)
+ (let (required-args)
+ (dotimes (i min-args) (push (gensym) required-args))
+ `(lambda (name)
+ (let ((inclusive-time 0)
+ (inclusive-cons 0)
+ (exclusive-time 0)
+ (exclusive-cons 0)
+ (calls 0)
+ (nested-calls 0)
+ (old-definition (place-function name)))
+ (declare (type time-type inclusive-time)
+ (type time-type exclusive-time)
+ (type consing-type inclusive-cons)
+ (type consing-type exclusive-cons)
+ (fixnum calls)
+ (fixnum nested-calls))
+ (pushnew name *monitored-functions*)
+
+ (setf (place-function name)
+ #'(lambda (,@required-args
+ ,@(when optionals-p
+ `(&rest optional-args)))
+ (let ((prev-total-time *total-time*)
+ (prev-total-cons *total-cons*)
+ (prev-total-calls *total-calls*)
+ ;; (old-time inclusive-time)
+ ;; (old-cons inclusive-cons)
+ ;; (old-nested-calls nested-calls)
+ )
+ (declare (type time-type prev-total-time)
+ (type consing-type prev-total-cons)
+ (fixnum prev-total-calls))
+ (with-time/cons (delta-time delta-cons)
+ ;; form
+ ,(if optionals-p
+ `(apply old-definition
+ ,@required-args optional-args)
+ `(funcall old-definition ,@required-args))
+ ;; post-processing:
+ ;; Calls
+ (incf calls)
+ (incf *total-calls*)
+ ;; nested-calls includes this call
+ (incf nested-calls (the fixnum
+ (- *total-calls*
+ prev-total-calls)))
+ ;; (setf nested-calls (+ old-nested-calls
+ ;; (- *total-calls*
+ ;; prev-total-calls)))
+ ;; Time
+ ;; Problem with inclusive time is that it
+ ;; currently doesn't add values from recursive
+ ;; calls to the same function. Change the
+ ;; setf to an incf to fix this?
+ (incf inclusive-time (the time-type delta-time))
+ ;; (setf inclusive-time (+ delta-time old-time))
+ (incf exclusive-time (the time-type
+ (+ delta-time
+ (- prev-total-time
+ *total-time*))))
+ (setf *total-time* (the time-type
+ (+ delta-time
+ prev-total-time)))
+ ;; Consing
+ (incf inclusive-cons (the consing-type delta-cons))
+ ;; (setf inclusive-cons (+ delta-cons old-cons))
+ (incf exclusive-cons (the consing-type
+ (+ delta-cons
+ (- prev-total-cons
+ *total-cons*))))
+ (setf *total-cons*
+ (the consing-type
+ (+ delta-cons prev-total-cons)))))))
+ (setf (get-monitor-info name)
+ (make-metering-functions
+ :name name
+ :old-definition old-definition
+ :new-definition (place-function name)
+ :read-metering #'(lambda ()
+ (values inclusive-time
+ inclusive-cons
+ exclusive-time
+ exclusive-cons
+ calls
+ nested-calls))
+ :reset-metering #'(lambda ()
+ (setq inclusive-time 0
+ inclusive-cons 0
+ exclusive-time 0
+ exclusive-cons 0
+ calls 0
+ nested-calls 0)
+ t)))))))
+);; End of EVAL-WHEN
+
+;;; For efficiency reasons, we precompute the encapsulation functions
+;;; for a variety of combinations of argument structures
+;;; (min-args . optional-p). These are stored in the following hash table
+;;; along with any new ones we encounter. Since we're now precomputing
+;;; closure functions for common argument signatures, this eliminates
+;;; the former need to call COMPILE for each monitored function.
+(eval-when (compile eval)
+ (defconstant precomputed-encapsulations 8))
+
+(defvar *existing-encapsulations* (make-hash-table :test #'equal))
+(defun find-encapsulation (min-args optionals-p)
+ (or (gethash (cons min-args optionals-p) *existing-encapsulations*)
+ (setf (gethash (cons min-args optionals-p) *existing-encapsulations*)
+ (compile nil
+ (make-monitoring-encapsulation min-args optionals-p)))))
+
+(macrolet ((frob ()
+ (let ((res ()))
+ (dotimes (i precomputed-encapsulations)
+ (push `(setf (gethash '(,i . nil) *existing-encapsulations*)
+ #',(make-monitoring-encapsulation i nil))
+ res)
+ (push `(setf (gethash '(,i . t) *existing-encapsulations*)
+ #',(make-monitoring-encapsulation i t))
+ res))
+ `(progn ,@res))))
+ (frob))
+
+(defun monitoring-encapsulate (name &optional warn)
+ "Monitor the function Name. If already monitored, unmonitor first."
+ ;; Saves the current definition of name and inserts a new function which
+ ;; returns the result of evaluating body.
+ (cond ((not (place-fboundp name)) ; not a function
+ (when warn
+ (warn "Ignoring undefined function ~S." name)))
+ ((place-macrop name) ; a macro
+ (when warn
+ (warn "Ignoring macro ~S." name)))
+ (t ; tis a function
+ (when (get-monitor-info name) ; monitored
+ (when warn
+ (warn "~S already monitored, so unmonitoring it first." name))
+ (monitoring-unencapsulate name))
+ (multiple-value-bind (min-args optionals-p)
+ (required-arguments name)
+ (funcall (find-encapsulation min-args optionals-p) name)))))
+
+(defun monitoring-unencapsulate (name &optional warn)
+ "Removes monitoring encapsulation code from around Name."
+ (let ((finfo (get-monitor-info name)))
+ (when finfo ; monitored
+ (remprop name 'metering-functions)
+ (setq *monitored-functions*
+ (remove name *monitored-functions* :test #'equal))
+ (if (eq (place-function name)
+ (metering-functions-new-definition finfo))
+ (setf (place-function name)
+ (metering-functions-old-definition finfo))
+ (when warn
+ (warn "Preserving current definition of redefined function ~S."
+ name))))))
+
+;;; ********************************
+;;; Main Monitoring Functions ******
+;;; ********************************
+(defmacro MONITOR (&rest names)
+ "Monitor the named functions. As in TRACE, the names are not evaluated.
+ If a function is already monitored, then unmonitor and remonitor (useful
+ to notice function redefinition). If a name is undefined, give a warning
+ and ignore it. See also unmonitor, report-monitoring,
+ display-monitoring-results and reset-time."
+ `(progn
+ ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names)
+ *monitored-functions*))
+
+(defmacro UNMONITOR (&rest names)
+ "Remove the monitoring on the named functions.
+ Names defaults to the list of all currently monitored functions."
+ `(dolist (name ,(if names `',names '*monitored-functions*) (values))
+ (monitoring-unencapsulate name)))
+
+(defun MONITOR-ALL (&optional (package *package*))
+ "Monitor all functions in the specified package."
+ (let ((package (if (packagep package)
+ package
+ (find-package package))))
+ (do-symbols (symbol package)
+ (when (eq (symbol-package symbol) package)
+ (monitoring-encapsulate symbol)))))
+
+(defmacro MONITOR-FORM (form
+ &optional (nested :exclusive) (threshold 0.01)
+ (key :percent-time))
+ "Monitor the execution of all functions in the current package
+during the execution of FORM. All functions that are executed above
+THRESHOLD % will be reported."
+ `(unwind-protect
+ (progn
+ (monitor-all)
+ (reset-all-monitoring)
+ (prog1
+ (time ,form)
+ (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls)))
+ (unmonitor)))
+
+(defmacro WITH-MONITORING ((&rest functions)
+ (&optional (nested :exclusive)
+ (threshold 0.01)
+ (key :percent-time))
+ &body body)
+ "Monitor the specified functions during the execution of the body."
+ `(unwind-protect
+ (progn
+ (dolist (fun ',functions)
+ (monitoring-encapsulate fun))
+ (reset-all-monitoring)
+ ,@body
+ (report-monitoring :all ,nested ,threshold ,key))
+ (unmonitor)))
+
+;;; ********************************
+;;; Overhead Calculations **********
+;;; ********************************
+(defconstant overhead-iterations 5000
+ "Number of iterations over which the timing overhead is averaged.")
+
+;;; Perhaps this should return something to frustrate clever compilers.
+(defun STUB-FUNCTION (x)
+ (declare (ignore x))
+ nil)
+(proclaim '(notinline stub-function))
+
+(defun SET-MONITOR-OVERHEAD ()
+ "Determines the average overhead of monitoring by monitoring the execution
+of an empty function many times."
+ (setq *monitor-time-overhead* 0
+ *monitor-cons-overhead* 0)
+ (stub-function nil)
+ (monitor stub-function)
+ (reset-all-monitoring)
+ (let ((overhead-function (symbol-function 'stub-function)))
+ (dotimes (x overhead-iterations)
+ (funcall overhead-function overhead-function)))
+; (dotimes (x overhead-iterations)
+; (stub-function nil))
+ (let ((fiter (float overhead-iterations)))
+ (multiple-value-bind (calls nested-calls time cons)
+ (monitor-info-values 'stub-function)
+ (declare (ignore calls nested-calls))
+ (setq *monitor-time-overhead* (/ time fiter)
+ *monitor-cons-overhead* (/ cons fiter))))
+ (unmonitor stub-function))
+(set-monitor-overhead)
+
+;;; ********************************
+;;; Report Data ********************
+;;; ********************************
+(defvar *monitor-results* nil
+ "A table of monitoring statistics is stored here.")
+(defvar *no-calls* nil
+ "A list of monitored functions which weren't called.")
+(defvar *estimated-total-overhead* 0)
+;; (proclaim '(type time-type *estimated-total-overhead*))
+
+(defstruct (monitoring-info
+ (:conc-name m-info-)
+ (:constructor make-monitoring-info
+ (name calls time cons
+ percent-time percent-cons
+ time-per-call cons-per-call)))
+ name
+ calls
+ time
+ cons
+ percent-time
+ percent-cons
+ time-per-call
+ cons-per-call)
+
+(defun REPORT (&key (names :all)
+ (nested :exclusive)
+ (threshold 0.01)
+ (sort-key :percent-time)
+ (ignore-no-calls nil))
+ "Same as REPORT-MONITORING but with a nicer keyword interface"
+ (declare (type (member :function :percent-time :time :percent-cons
+ :cons :calls :time-per-call :cons-per-call)
+ sort-key)
+ (type (member :inclusive :exclusive) nested))
+ (report-monitoring names nested threshold sort-key ignore-no-calls))
+
+(defun REPORT-MONITORING (&optional names
+ (nested :exclusive)
+ (threshold 0.01)
+ (key :percent-time)
+ ignore-no-calls)
+ "Report the current monitoring state.
+The percentage of the total time spent executing unmonitored code
+in each function (:exclusive mode), or total time (:inclusive mode)
+will be printed together with the number of calls and
+the unmonitored time per call. Functions that have been executed
+below THRESHOLD % of the time will not be reported. To report on all
+functions set NAMES to be either NIL or :ALL."
+ (when (or (null names) (eq names :all)) (setq names *monitored-functions*))
+
+ (let ((total-time 0)
+ (total-cons 0)
+ (total-calls 0))
+ ;; Compute overall time and consing.
+ (dolist (name names)
+ (multiple-value-bind (calls nested-calls time cons)
+ (monitor-info-values name nested :warn)
+ (declare (ignore nested-calls))
+ (incf total-calls calls)
+ (incf total-time time)
+ (incf total-cons cons)))
+ ;; Total overhead.
+ (setq *estimated-total-overhead*
+ (/ (* *monitor-time-overhead* total-calls)
+ time-units-per-second))
+ ;; Assemble data for only the specified names (all monitored functions)
+ (if (zerop total-time)
+ (format *trace-output* "Not enough execution time to monitor.")
+ (progn
+ (setq *monitor-results* nil *no-calls* nil)
+ (dolist (name names)
+ (multiple-value-bind (calls nested-calls time cons)
+ (monitor-info-values name nested)
+ (declare (ignore nested-calls))
+ (when (minusp time) (setq time 0.0))
+ (when (minusp cons) (setq cons 0.0))
+ (if (zerop calls)
+ (push (if (symbolp name)
+ (symbol-name name)
+ (format nil "~S" name))
+ *no-calls*)
+ (push (make-monitoring-info
+ (format nil "~S" name) ; name
+ calls ; calls
+ (/ time (float time-units-per-second)) ; time in secs
+ (round cons) ; consing
+ (/ time (float total-time)) ; percent-time
+ (if (zerop total-cons) 0
+ (/ cons (float total-cons))) ; percent-cons
+ (/ (/ time (float calls)) ; time-per-call
+ time-units-per-second) ; sec/call
+ (round (/ cons (float calls)))) ; cons-per-call
+ *monitor-results*))))
+ (display-monitoring-results threshold key ignore-no-calls)))))
+
+(defun display-monitoring-results (&optional (threshold 0.01)
+ (key :percent-time)
+ (ignore-no-calls t))
+ (let ((max-length 8) ; Function header size
+ (max-cons-length 8)
+ (total-time 0.0)
+ (total-consed 0)
+ (total-calls 0)
+ (total-percent-time 0)
+ (total-percent-cons 0))
+ (sort-results key)
+ (dolist (result *monitor-results*)
+ (when (or (zerop threshold)
+ (> (m-info-percent-time result) threshold))
+ (setq max-length
+ (max max-length
+ (length (m-info-name result))))
+ (setq max-cons-length
+ (max max-cons-length
+ (m-info-cons-per-call result)))))
+ (incf max-length 2)
+ (setf max-cons-length (+ 2 (ceiling (log max-cons-length 10))))
+ (format *trace-output*
+ "~%~%~
+ ~VT ~VA~
+ ~% ~VT % % ~VA ~
+Total Total~
+ ~%Function~VT Time Cons Calls Sec/Call ~VA ~
+Time Cons~
+ ~%~V,,,'-A"
+ max-length
+ max-cons-length "Cons"
+ max-length
+ max-cons-length "Per"
+ max-length
+ max-cons-length "Call"
+ (+ max-length 62 (max 0 (- max-cons-length 5))) "-")
+ (dolist (result *monitor-results*)
+ (when (or (zerop threshold)
+ (> (m-info-percent-time result) threshold))
+ (format *trace-output*
+ "~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D"
+ (m-info-name result)
+ max-length
+ (* 100 (m-info-percent-time result))
+ (* 100 (m-info-percent-cons result))
+ (m-info-calls result)
+ (m-info-time-per-call result)
+ max-cons-length
+ (m-info-cons-per-call result)
+ (m-info-time result)
+ (m-info-cons result))
+ (incf total-time (m-info-time result))
+ (incf total-consed (m-info-cons result))
+ (incf total-calls (m-info-calls result))
+ (incf total-percent-time (m-info-percent-time result))
+ (incf total-percent-cons (m-info-percent-cons result))))
+ (format *trace-output*
+ "~%~V,,,'-A~
+ ~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~
+ ~%Estimated monitoring overhead: ~5,2F seconds~
+ ~%Estimated total monitoring overhead: ~5,2F seconds"
+ (+ max-length 62 (max 0 (- max-cons-length 5))) "-"
+ max-length
+ (* 100 total-percent-time)
+ (* 100 total-percent-cons)
+ total-calls
+ max-cons-length " "
+ total-time total-consed
+ (/ (* *monitor-time-overhead* total-calls)
+ time-units-per-second)
+ *estimated-total-overhead*)
+ (when (and (not ignore-no-calls) *no-calls*)
+ (setq *no-calls* (sort *no-calls* #'string<))
+ (let ((num-no-calls (length *no-calls*)))
+ (if (> num-no-calls 20)
+ (format *trace-output*
+ "~%~@(~r~) monitored functions were not called. ~
+ ~%See the variable swank-monitor::*no-calls* for a list."
+ num-no-calls)
+ (format *trace-output*
+ "~%The following monitored functions were not called:~
+ ~%~{~<~%~:; ~A~>~}~%"
+ *no-calls*))))
+ (values)))
+
+(defun sort-results (&optional (key :percent-time))
+ (setq *monitor-results*
+ (case key
+ (:function (sort *monitor-results* #'string>
+ :key #'m-info-name))
+ ((:percent-time :time) (sort *monitor-results* #'>
+ :key #'m-info-time))
+ ((:percent-cons :cons) (sort *monitor-results* #'>
+ :key #'m-info-cons))
+ (:calls (sort *monitor-results* #'>
+ :key #'m-info-calls))
+ (:time-per-call (sort *monitor-results* #'>
+ :key #'m-info-time-per-call))
+ (:cons-per-call (sort *monitor-results* #'>
+ :key #'m-info-cons-per-call)))))
+
+;;; *END OF FILE*
+
+
diff --git a/vim/bundle/slimv/slime/nregex.lisp b/vim/bundle/slimv/slime/nregex.lisp
new file mode 100644
index 0000000..43586ef
--- /dev/null
+++ b/vim/bundle/slimv/slime/nregex.lisp
@@ -0,0 +1,523 @@
+;;;
+;;; This code was written by:
+;;;
+;;; Lawrence E. Freil <lef@freil.com>
+;;; National Science Center Foundation
+;;; Augusta, Georgia 30909
+;;;
+;;; This program was released into the public domain on 2005-08-31.
+;;; (See the slime-devel mailing list archive for details.)
+;;;
+;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression
+;;; parser.
+;;;
+;;; This regular expression parser operates by taking a
+;;; regular expression and breaking it down into a list
+;;; consisting of lisp expressions and flags. The list
+;;; of lisp expressions is then taken in turned into a
+;;; lambda expression that can be later applied to a
+;;; string argument for parsing.
+;;;;
+;;;; Modifications made 6 March 2001 By Chris Double (chris@double.co.nz)
+;;;; to get working with Corman Lisp 1.42, add package statement and export
+;;;; relevant functions.
+;;;;
+
+(in-package :cl-user)
+
+;; Renamed to slime-nregex avoid name clashes with other versions of
+;; this file. -- he
+
+;;;; CND - 6/3/2001
+(defpackage slime-nregex
+ (:use #:common-lisp)
+ (:export
+ #:regex
+ #:regex-compile
+ ))
+
+;;;; CND - 6/3/2001
+(in-package :slime-nregex)
+
+;;;
+;;; First we create a copy of macros to help debug the beast
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defvar *regex-debug* nil) ; Set to nil for no debugging code
+)
+
+(defmacro info (message &rest args)
+ (if *regex-debug*
+ `(format *standard-output* ,message ,@args)))
+
+;;;
+;;; Declare the global variables for storing the paren index list.
+;;;
+(defvar *regex-groups* (make-array 10))
+(defvar *regex-groupings* 0)
+
+;;;
+;;; Declare a simple interface for testing. You probably wouldn't want
+;;; to use this interface unless you were just calling this once.
+;;;
+(defun regex (expression string)
+ "Usage: (regex <expression> <string)
+ This function will call regex-compile on the expression and then apply
+ the string to the returned lambda list."
+ (let ((findit (cond ((stringp expression)
+ (regex-compile expression))
+ ((listp expression)
+ expression)))
+ (result nil))
+ (if (not (funcall (if (functionp findit)
+ findit
+ (eval `(function ,findit))) string))
+ (return-from regex nil))
+ (if (= *regex-groupings* 0)
+ (return-from regex t))
+ (dotimes (i *regex-groupings*)
+ (push (funcall 'subseq
+ string
+ (car (aref *regex-groups* i))
+ (cadr (aref *regex-groups* i)))
+ result))
+ (reverse result)))
+
+;;;
+;;; Declare some simple macros to make the code more readable.
+;;;
+(defvar *regex-special-chars* "?*+.()[]\\${}")
+
+(defmacro add-exp (list)
+ "Add an item to the end of expression"
+ `(setf expression (append expression ,list)))
+
+;;;
+;;; Define a function that will take a quoted character and return
+;;; what the real character should be plus how much of the source
+;;; string was used. If the result is a set of characters, return an
+;;; array of bits indicating which characters should be set. If the
+;;; expression is one of the sub-group matches return a
+;;; list-expression that will provide the match.
+;;;
+(defun regex-quoted (char-string &optional (invert nil))
+ "Usage: (regex-quoted <char-string> &optional invert)
+ Returns either the quoted character or a simple bit vector of bits set for
+ the matching values"
+ (let ((first (char char-string 0))
+ (result (char char-string 0))
+ (used-length 1))
+ (cond ((eql first #\n)
+ (setf result #\NewLine))
+ ((eql first #\c)
+ (setf result #\Return))
+ ((eql first #\t)
+ (setf result #\Tab))
+ ((eql first #\d)
+ (setf result #*0000000000000000000000000000000000000000000000001111111111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+ ((eql first #\D)
+ (setf result #*1111111111111111111111111111111111111111111111110000000000111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+ ((eql first #\w)
+ (setf result #*0000000000000000000000000000000000000000000000001111111111000000011111111111111111111111111000010111111111111111111111111110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+ ((eql first #\W)
+ (setf result #*1111111111111111111111111111111111111111111111110000000000111111100000000000000000000000000111101000000000000000000000000001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+ ((eql first #\b)
+ (setf result #*0000000001000000000000000000000011000000000010100000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+ ((eql first #\B)
+ (setf result #*1111111110111111111111111111111100111111111101011111111111011111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+ ((eql first #\s)
+ (setf result #*0000000001100000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+ ((eql first #\S)
+ (setf result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+ ((and (>= (char-code first) (char-code #\0))
+ (<= (char-code first) (char-code #\9)))
+ (if (and (> (length char-string) 2)
+ (and (>= (char-code (char char-string 1)) (char-code #\0))
+ (<= (char-code (char char-string 1)) (char-code #\9))
+ (>= (char-code (char char-string 2)) (char-code #\0))
+ (<= (char-code (char char-string 2)) (char-code #\9))))
+ ;;
+ ;; It is a single character specified in octal
+ ;;
+ (progn
+ (setf result (do ((x 0 (1+ x))
+ (return 0))
+ ((= x 2) return)
+ (setf return (+ (* return 8)
+ (- (char-code (char char-string x))
+ (char-code #\0))))))
+ (setf used-length 3))
+ ;;
+ ;; We have a group number replacement.
+ ;;
+ (let ((group (- (char-code first) (char-code #\0))))
+ (setf result `((let ((nstring (subseq string (car (aref *regex-groups* ,group))
+ (cadr (aref *regex-groups* ,group)))))
+ (if (< length (+ index (length nstring)))
+ (return-from compare nil))
+ (if (not (string= string nstring
+ :start1 index
+ :end1 (+ index (length nstring))))
+ (return-from compare nil)
+ (incf index (length nstring)))))))))
+ (t
+ (setf result first)))
+ (if (and (vectorp result) invert)
+ (bit-xor result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 t))
+ (values result used-length)))
+
+;;;
+;;; Now for the main regex compiler routine.
+;;;
+(defun regex-compile (source &key (anchored nil))
+ "Usage: (regex-compile <expression> [ :anchored (t/nil) ])
+ This function take a regular expression (supplied as source) and
+ compiles this into a lambda list that a string argument can then
+ be applied to. It is also possible to compile this lambda list
+ for better performance or to save it as a named function for later
+ use"
+ (info "Now entering regex-compile with \"~A\"~%" source)
+ ;;
+ ;; This routine works in two parts.
+ ;; The first pass take the regular expression and produces a list of
+ ;; operators and lisp expressions for the entire regular expression.
+ ;; The second pass takes this list and produces the lambda expression.
+ (let ((expression '()) ; holder for expressions
+ (group 1) ; Current group index
+ (group-stack nil) ; Stack of current group endings
+ (result nil) ; holder for built expression.
+ (fast-first nil)) ; holder for quick unanchored scan
+ ;;
+ ;; If the expression was an empty string then it alway
+ ;; matches (so lets leave early)
+ ;;
+ (if (= (length source) 0)
+ (return-from regex-compile
+ '(lambda (&rest args)
+ (declare (ignore args))
+ t)))
+ ;;
+ ;; If the first character is a caret then set the anchored
+ ;; flags and remove if from the expression string.
+ ;;
+ (cond ((eql (char source 0) #\^)
+ (setf source (subseq source 1))
+ (setf anchored t)))
+ ;;
+ ;; If the first sequence is .* then also set the anchored flags.
+ ;; (This is purely for optimization, it will work without this).
+ ;;
+ (if (>= (length source) 2)
+ (if (string= source ".*" :start1 0 :end1 2)
+ (setf anchored t)))
+ ;;
+ ;; Also, If this is not an anchored search and the first character is
+ ;; a literal, then do a quick scan to see if it is even in the string.
+ ;; If not then we can issue a quick nil,
+ ;; otherwise we can start the search at the matching character to skip
+ ;; the checks of the non-matching characters anyway.
+ ;;
+ ;; If I really wanted to speed up this section of code it would be
+ ;; easy to recognize the case of a fairly long multi-character literal
+ ;; and generate a Boyer-Moore search for the entire literal.
+ ;;
+ ;; I generate the code to do a loop because on CMU Lisp this is about
+ ;; twice as fast a calling position.
+ ;;
+ (if (and (not anchored)
+ (not (position (char source 0) *regex-special-chars*))
+ (not (and (> (length source) 1)
+ (position (char source 1) *regex-special-chars*))))
+ (setf fast-first `((if (not (dotimes (i length nil)
+ (if (eql (char string i)
+ ,(char source 0))
+ (return (setf start i)))))
+ (return-from final-return nil)))))
+ ;;
+ ;; Generate the very first expression to save the starting index
+ ;; so that group 0 will be the entire string matched always
+ ;;
+ (add-exp '((setf (aref *regex-groups* 0)
+ (list index nil))))
+ ;;
+ ;; Loop over each character in the regular expression building the
+ ;; expression list as we go.
+ ;;
+ (do ((eindex 0 (1+ eindex)))
+ ((= eindex (length source)))
+ (let ((current (char source eindex)))
+ (info "Now processing character ~A index = ~A~%" current eindex)
+ (case current
+ ((#\.)
+ ;;
+ ;; Generate code for a single wild character
+ ;;
+ (add-exp '((if (>= index length)
+ (return-from compare nil)
+ (incf index)))))
+ ((#\$)
+ ;;
+ ;; If this is the last character of the expression then
+ ;; anchor the end of the expression, otherwise let it slide
+ ;; as a standard character (even though it should be quoted).
+ ;;
+ (if (= eindex (1- (length source)))
+ (add-exp '((if (not (= index length))
+ (return-from compare nil))))
+ (add-exp '((if (not (and (< index length)
+ (eql (char string index) #\$)))
+ (return-from compare nil)
+ (incf index))))))
+ ((#\*)
+ (add-exp '(ASTRISK)))
+
+ ((#\+)
+ (add-exp '(PLUS)))
+
+ ((#\?)
+ (add-exp '(QUESTION)))
+
+ ((#\()
+ ;;
+ ;; Start a grouping.
+ ;;
+ (incf group)
+ (push group group-stack)
+ (add-exp `((setf (aref *regex-groups* ,(1- group))
+ (list index nil))))
+ (add-exp `(,group)))
+ ((#\))
+ ;;
+ ;; End a grouping
+ ;;
+ (let ((group (pop group-stack)))
+ (add-exp `((setf (cadr (aref *regex-groups* ,(1- group)))
+ index)))
+ (add-exp `(,(- group)))))
+ ((#\[)
+ ;;
+ ;; Start of a range operation.
+ ;; Generate a bit-vector that has one bit per possible character
+ ;; and then on each character or range, set the possible bits.
+ ;;
+ ;; If the first character is carat then invert the set.
+ (let* ((invert (eql (char source (1+ eindex)) #\^))
+ (bitstring (make-array 256 :element-type 'bit
+ :initial-element
+ (if invert 1 0)))
+ (set-char (if invert 0 1)))
+ (if invert (incf eindex))
+ (do ((x (1+ eindex) (1+ x)))
+ ((eql (char source x) #\]) (setf eindex x))
+ (info "Building range with character ~A~%" (char source x))
+ (cond ((and (eql (char source (1+ x)) #\-)
+ (not (eql (char source (+ x 2)) #\])))
+ (if (>= (char-code (char source x))
+ (char-code (char source (+ 2 x))))
+ (error "Invalid range \"~A-~A\". Ranges must be in acending order"
+ (char source x) (char source (+ 2 x))))
+ (do ((j (char-code (char source x)) (1+ j)))
+ ((> j (char-code (char source (+ 2 x))))
+ (incf x 2))
+ (info "Setting bit for char ~A code ~A~%" (code-char j) j)
+ (setf (sbit bitstring j) set-char)))
+ (t
+ (cond ((not (eql (char source x) #\]))
+ (let ((char (char source x)))
+ ;;
+ ;; If the character is quoted then find out what
+ ;; it should have been
+ ;;
+ (if (eql (char source x) #\\ )
+ (let ((length))
+ (multiple-value-setq (char length)
+ (regex-quoted (subseq source x) invert))
+ (incf x length)))
+ (info "Setting bit for char ~A code ~A~%" char (char-code char))
+ (if (not (vectorp char))
+ (setf (sbit bitstring (char-code (char source x))) set-char)
+ (bit-ior bitstring char t))))))))
+ (add-exp `((let ((range ,bitstring))
+ (if (>= index length)
+ (return-from compare nil))
+ (if (= 1 (sbit range (char-code (char string index))))
+ (incf index)
+ (return-from compare nil)))))))
+ ((#\\ )
+ ;;
+ ;; Intreprete the next character as a special, range, octal, group or
+ ;; just the character itself.
+ ;;
+ (let ((length)
+ (value))
+ (multiple-value-setq (value length)
+ (regex-quoted (subseq source (1+ eindex)) nil))
+ (cond ((listp value)
+ (add-exp value))
+ ((characterp value)
+ (add-exp `((if (not (and (< index length)
+ (eql (char string index)
+ ,value)))
+ (return-from compare nil)
+ (incf index)))))
+ ((vectorp value)
+ (add-exp `((let ((range ,value))
+ (if (>= index length)
+ (return-from compare nil))
+ (if (= 1 (sbit range (char-code (char string index))))
+ (incf index)
+ (return-from compare nil)))))))
+ (incf eindex length)))
+ (t
+ ;;
+ ;; We have a literal character.
+ ;; Scan to see how many we have and if it is more than one
+ ;; generate a string= verses as single eql.
+ ;;
+ (let* ((lit "")
+ (term (dotimes (litindex (- (length source) eindex) nil)
+ (let ((litchar (char source (+ eindex litindex))))
+ (if (position litchar *regex-special-chars*)
+ (return litchar)
+ (progn
+ (info "Now adding ~A index ~A to lit~%" litchar
+ litindex)
+ (setf lit (concatenate 'string lit
+ (string litchar)))))))))
+ (if (= (length lit) 1)
+ (add-exp `((if (not (and (< index length)
+ (eql (char string index) ,current)))
+ (return-from compare nil)
+ (incf index))))
+ ;;
+ ;; If we have a multi-character literal then we must
+ ;; check to see if the next character (if there is one)
+ ;; is an astrisk or a plus or a question mark. If so then we must not use this
+ ;; character in the big literal.
+ (progn
+ (if (or (eql term #\*)
+ (eql term #\+)
+ (eql term #\?))
+ (setf lit (subseq lit 0 (1- (length lit)))))
+ (add-exp `((if (< length (+ index ,(length lit)))
+ (return-from compare nil))
+ (if (not (string= string ,lit :start1 index
+ :end1 (+ index ,(length lit))))
+ (return-from compare nil)
+ (incf index ,(length lit)))))))
+ (incf eindex (1- (length lit))))))))
+ ;;
+ ;; Plug end of list to return t. If we made it this far then
+ ;; We have matched!
+ (add-exp '((setf (cadr (aref *regex-groups* 0))
+ index)))
+ (add-exp '((return-from final-return t)))
+ ;;
+;;; (print expression)
+ ;;
+ ;; Now take the expression list and turn it into a lambda expression
+ ;; replacing the special flags with lisp code.
+ ;; For example: A BEGIN needs to be replace by an expression that
+ ;; saves the current index, then evaluates everything till it gets to
+ ;; the END then save the new index if it didn't fail.
+ ;; On an ASTRISK I need to take the previous expression and wrap
+ ;; it in a do that will evaluate the expression till an error
+ ;; occurs and then another do that encompases the remainder of the
+ ;; regular expression and iterates decrementing the index by one
+ ;; of the matched expression sizes and then returns nil. After
+ ;; the last expression insert a form that does a return t so that
+ ;; if the entire nested sub-expression succeeds then the loop
+ ;; is broken manually.
+ ;;
+ (setf result (copy-tree nil))
+ ;;
+ ;; Reversing the current expression makes building up the
+ ;; lambda list easier due to the nexting of expressions when
+ ;; and astrisk has been encountered.
+ (setf expression (reverse expression))
+ (do ((elt 0 (1+ elt)))
+ ((>= elt (length expression)))
+ (let ((piece (nth elt expression)))
+ ;;
+ ;; Now check for PLUS, if so then ditto the expression and then let the
+ ;; ASTRISK below handle the rest.
+ ;;
+ (cond ((eql piece 'PLUS)
+ (cond ((listp (nth (1+ elt) expression))
+ (setf result (append (list (nth (1+ elt) expression))
+ result)))
+ ;;
+ ;; duplicate the entire group
+ ;; NOTE: This hasn't been implemented yet!!
+ (t
+ (error "GROUP repeat hasn't been implemented yet~%")))))
+ (cond ((listp piece) ;Just append the list
+ (setf result (append (list piece) result)))
+ ((eql piece 'QUESTION) ; Wrap it in a block that won't fail
+ (cond ((listp (nth (1+ elt) expression))
+ (setf result
+ (append `((progn (block compare
+ ,(nth (1+ elt)
+ expression))
+ t))
+ result))
+ (incf elt))
+ ;;
+ ;; This is a QUESTION on an entire group which
+ ;; hasn't been implemented yet!!!
+ ;;
+ (t
+ (error "Optional groups not implemented yet~%"))))
+ ((or (eql piece 'ASTRISK) ; Do the wild thing!
+ (eql piece 'PLUS))
+ (cond ((listp (nth (1+ elt) expression))
+ ;;
+ ;; This is a single character wild card so
+ ;; do the simple form.
+ ;;
+ (setf result
+ `((let ((oindex index))
+ (block compare
+ (do ()
+ (nil)
+ ,(nth (1+ elt) expression)))
+ (do ((start index (1- start)))
+ ((< start oindex) nil)
+ (let ((index start))
+ (block compare
+ ,@result))))))
+ (incf elt))
+ (t
+ ;;
+ ;; This is a subgroup repeated so I must build
+ ;; the loop using several values.
+ ;;
+ ))
+ )
+ (t t)))) ; Just ignore everything else.
+ ;;
+ ;; Now wrap the result in a lambda list that can then be
+ ;; invoked or compiled, however the user wishes.
+ ;;
+ (if anchored
+ (setf result
+ `(lambda (string &key (start 0) (end (length string)))
+ (setf *regex-groupings* ,group)
+ (block final-return
+ (block compare
+ (let ((index start)
+ (length end))
+ ,@result)))))
+ (setf result
+ `(lambda (string &key (start 0) (end (length string)))
+ (setf *regex-groupings* ,group)
+ (block final-return
+ (let ((length end))
+ ,@fast-first
+ (do ((marker start (1+ marker)))
+ ((> marker end) nil)
+ (let ((index marker))
+ (if (block compare
+ ,@result)
+ (return t)))))))))))
+
+;; (provide 'nregex)
diff --git a/vim/bundle/slimv/slime/packages.lisp b/vim/bundle/slimv/slime/packages.lisp
new file mode 100644
index 0000000..df7b929
--- /dev/null
+++ b/vim/bundle/slimv/slime/packages.lisp
@@ -0,0 +1,194 @@
+(defpackage swank/backend
+ (:use cl)
+ (:nicknames swank-backend)
+ (:export *debug-swank-backend*
+ *log-output*
+ sldb-condition
+ compiler-condition
+ original-condition
+ message
+ source-context
+ condition
+ severity
+ with-compilation-hooks
+ make-location
+ location
+ location-p
+ location-buffer
+ location-position
+ location-hints
+ position-p
+ position-pos
+ print-output-to-string
+ quit-lisp
+ references
+ unbound-slot-filler
+ declaration-arglist
+ type-specifier-arglist
+ with-struct
+ when-let
+ defimplementation
+ converting-errors-to-error-location
+ make-error-location
+ deinit-log-output
+ ;; interrupt macro for the backend
+ *pending-slime-interrupts*
+ check-slime-interrupts
+ *interrupt-queued-handler*
+ ;; inspector related symbols
+ emacs-inspect
+ label-value-line
+ label-value-line*
+ boolean-to-feature-expression
+ with-symbol
+ choose-symbol
+ ;; package helper for backend
+ import-to-swank-mop
+ import-swank-mop-symbols
+ ;;
+ default-directory
+ set-default-directory
+ frame-source-location
+ restart-frame
+ gdb-initial-commands
+ sldb-break-on-return
+ buffer-first-change
+
+ profiled-functions
+ unprofile-all
+ profile-report
+ profile-reset
+ profile-package
+
+ with-collected-macro-forms))
+
+(defpackage swank/rpc
+ (:use :cl)
+ (:export
+ read-message
+ swank-reader-error
+ swank-reader-error.packet
+ swank-reader-error.cause
+ write-message))
+
+(defpackage swank/match
+ (:use cl)
+ (:export match))
+
+;; FIXME: rename to sawnk/mop
+(defpackage swank-mop
+ (:use)
+ (:export
+ ;; classes
+ standard-generic-function
+ standard-slot-definition
+ standard-method
+ standard-class
+ eql-specializer
+ eql-specializer-object
+ ;; standard-class readers
+ class-default-initargs
+ class-direct-default-initargs
+ class-direct-slots
+ class-direct-subclasses
+ class-direct-superclasses
+ class-finalized-p
+ class-name
+ class-precedence-list
+ class-prototype
+ class-slots
+ specializer-direct-methods
+ ;; generic function readers
+ generic-function-argument-precedence-order
+ generic-function-declarations
+ generic-function-lambda-list
+ generic-function-methods
+ generic-function-method-class
+ generic-function-method-combination
+ generic-function-name
+ ;; method readers
+ method-generic-function
+ method-function
+ method-lambda-list
+ method-specializers
+ method-qualifiers
+ ;; slot readers
+ slot-definition-allocation
+ slot-definition-documentation
+ slot-definition-initargs
+ slot-definition-initform
+ slot-definition-initfunction
+ slot-definition-name
+ slot-definition-type
+ slot-definition-readers
+ slot-definition-writers
+ slot-boundp-using-class
+ slot-value-using-class
+ slot-makunbound-using-class
+ ;; generic function protocol
+ compute-applicable-methods-using-classes
+ finalize-inheritance))
+
+(defpackage swank
+ (:use cl swank/backend swank/match swank/rpc)
+ (:export #:startup-multiprocessing
+ #:start-server
+ #:create-server
+ #:stop-server
+ #:restart-server
+ #:ed-in-emacs
+ #:inspect-in-emacs
+ #:print-indentation-lossage
+ #:invoke-slime-debugger
+ #:swank-debugger-hook
+ #:emacs-inspect
+ ;;#:inspect-slot-for-emacs
+ ;; These are user-configurable variables:
+ #:*communication-style*
+ #:*dont-close*
+ #:*fasl-pathname-function*
+ #:*log-events*
+ #:*use-dedicated-output-stream*
+ #:*dedicated-output-stream-port*
+ #:*configure-emacs-indentation*
+ #:*readtable-alist*
+ #:*globally-redirect-io*
+ #:*global-debugger*
+ #:*sldb-quit-restart*
+ #:*backtrace-printer-bindings*
+ #:*default-worker-thread-bindings*
+ #:*macroexpand-printer-bindings*
+ #:*swank-pprint-bindings*
+ #:*record-repl-results*
+ #:*inspector-verbose*
+ ;; This is SETFable.
+ #:debug-on-swank-error
+ ;; These are re-exported directly from the backend:
+ #:buffer-first-change
+ #:frame-source-location
+ #:gdb-initial-commands
+ #:restart-frame
+ #:sldb-step
+ #:sldb-break
+ #:sldb-break-on-return
+ #:profiled-functions
+ #:profile-report
+ #:profile-reset
+ #:unprofile-all
+ #:profile-package
+ #:default-directory
+ #:set-default-directory
+ #:quit-lisp
+ #:eval-for-emacs
+ #:eval-in-emacs
+ #:y-or-n-p-in-emacs
+ #:*find-definitions-right-trim*
+ #:*find-definitions-left-trim*
+ #:*after-toggle-trace-hook*
+ #:unredable-result
+ #:unredable-result-p
+ #:unredable-result-string
+ #:parse-string
+ #:from-string
+ #:to-string
+ #:*swank-debugger-condition*))
diff --git a/vim/bundle/slimv/slime/sbcl-pprint-patch.lisp b/vim/bundle/slimv/slime/sbcl-pprint-patch.lisp
new file mode 100644
index 0000000..dfdc0bb
--- /dev/null
+++ b/vim/bundle/slimv/slime/sbcl-pprint-patch.lisp
@@ -0,0 +1,332 @@
+;; Pretty printer patch for SBCL, which adds the "annotations" feature
+;; required for sending presentations through pretty-printing streams.
+;;
+;; The section marked "Changed functions" and the DEFSTRUCT
+;; PRETTY-STREAM are based on SBCL's pprint.lisp.
+;;
+;; Public domain.
+
+(in-package "SB!PRETTY")
+
+(defstruct (annotation (:include queued-op))
+ (handler (constantly nil) :type function)
+ (record))
+
+
+(defstruct (pretty-stream (:include sb!kernel:ansi-stream
+ (out #'pretty-out)
+ (sout #'pretty-sout)
+ (misc #'pretty-misc))
+ (:constructor make-pretty-stream (target))
+ (:copier nil))
+ ;; Where the output is going to finally go.
+ (target (missing-arg) :type stream)
+ ;; Line length we should format to. Cached here so we don't have to keep
+ ;; extracting it from the target stream.
+ (line-length (or *print-right-margin*
+ (sb!impl::line-length target)
+ default-line-length)
+ :type column)
+ ;; A simple string holding all the text that has been output but not yet
+ ;; printed.
+ (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
+ ;; The index into BUFFER where more text should be put.
+ (buffer-fill-pointer 0 :type index)
+ ;; Whenever we output stuff from the buffer, we shift the remaining noise
+ ;; over. This makes it difficult to keep references to locations in
+ ;; the buffer. Therefore, we have to keep track of the total amount of
+ ;; stuff that has been shifted out of the buffer.
+ (buffer-offset 0 :type posn)
+ ;; The column the first character in the buffer will appear in. Normally
+ ;; zero, but if we end up with a very long line with no breaks in it we
+ ;; might have to output part of it. Then this will no longer be zero.
+ (buffer-start-column (or (sb!impl::charpos target) 0) :type column)
+ ;; The line number we are currently on. Used for *PRINT-LINES*
+ ;; abbreviations and to tell when sections have been split across
+ ;; multiple lines.
+ (line-number 0 :type index)
+ ;; the value of *PRINT-LINES* captured at object creation time. We
+ ;; use this, instead of the dynamic *PRINT-LINES*, to avoid
+ ;; weirdness like
+ ;; (let ((*print-lines* 50))
+ ;; (pprint-logical-block ..
+ ;; (dotimes (i 10)
+ ;; (let ((*print-lines* 8))
+ ;; (print (aref possiblybigthings i) prettystream)))))
+ ;; terminating the output of the entire logical blockafter 8 lines.
+ (print-lines *print-lines* :type (or index null) :read-only t)
+ ;; Stack of logical blocks in effect at the buffer start.
+ (blocks (list (make-logical-block)) :type list)
+ ;; Buffer holding the per-line prefix active at the buffer start.
+ ;; Indentation is included in this. The length of this is stored
+ ;; in the logical block stack.
+ (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
+ ;; Buffer holding the total remaining suffix active at the buffer start.
+ ;; The characters are right-justified in the buffer to make it easier
+ ;; to output the buffer. The length is stored in the logical block
+ ;; stack.
+ (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
+ ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
+ ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
+ ;; cons. Adding things to the queue is basically (setf (cdr head) (list
+ ;; new)) and removing them is basically (pop tail) [except that care must
+ ;; be taken to handle the empty queue case correctly.]
+ (queue-tail nil :type list)
+ (queue-head nil :type list)
+ ;; Block-start queue entries in effect at the queue head.
+ (pending-blocks nil :type list)
+ ;; Queue of annotations to the buffer
+ (annotations-tail nil :type list)
+ (annotations-head nil :type list))
+
+
+(defmacro enqueue (stream type &rest args)
+ (let ((constructor (intern (concatenate 'string
+ "MAKE-"
+ (symbol-name type))
+ "SB-PRETTY")))
+ (once-only ((stream stream)
+ (entry `(,constructor :posn
+ (index-posn
+ (pretty-stream-buffer-fill-pointer
+ ,stream)
+ ,stream)
+ ,@args))
+ (op `(list ,entry))
+ (head `(pretty-stream-queue-head ,stream)))
+ `(progn
+ (if ,head
+ (setf (cdr ,head) ,op)
+ (setf (pretty-stream-queue-tail ,stream) ,op))
+ (setf (pretty-stream-queue-head ,stream) ,op)
+ ,entry))))
+
+;;;
+;;; New helper functions
+;;;
+
+(defun enqueue-annotation (stream handler record)
+ (enqueue stream annotation :handler handler
+ :record record))
+
+(defun re-enqueue-annotation (stream annotation)
+ (let* ((annotation-cons (list annotation))
+ (head (pretty-stream-annotations-head stream)))
+ (if head
+ (setf (cdr head) annotation-cons)
+ (setf (pretty-stream-annotations-tail stream) annotation-cons))
+ (setf (pretty-stream-annotations-head stream) annotation-cons)
+ nil))
+
+(defun re-enqueue-annotations (stream end)
+ (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail)
+ while (and tail (not (eql (car tail) end)))
+ when (annotation-p (car tail))
+ do (re-enqueue-annotation stream (car tail))))
+
+(defun dequeue-annotation (stream &key end-posn)
+ (let ((next-annotation (car (pretty-stream-annotations-tail stream))))
+ (when next-annotation
+ (when (or (not end-posn)
+ (<= (annotation-posn next-annotation) end-posn))
+ (pop (pretty-stream-annotations-tail stream))
+ (unless (pretty-stream-annotations-tail stream)
+ (setf (pretty-stream-annotations-head stream) nil))
+ next-annotation))))
+
+(defun invoke-annotation (stream annotation truncatep)
+ (let ((target (pretty-stream-target stream)))
+ (funcall (annotation-handler annotation)
+ (annotation-record annotation)
+ target
+ truncatep)))
+
+(defun output-buffer-with-annotations (stream end)
+ (let ((target (pretty-stream-target stream))
+ (buffer (pretty-stream-buffer stream))
+ (end-posn (index-posn end stream))
+ (start 0))
+ (loop
+ for annotation = (dequeue-annotation stream :end-posn end-posn)
+ while annotation
+ do
+ (let ((annotation-index (posn-index (annotation-posn annotation)
+ stream)))
+ (when (> annotation-index start)
+ (write-string buffer target :start start
+ :end annotation-index)
+ (setf start annotation-index))
+ (invoke-annotation stream annotation nil)))
+ (when (> end start)
+ (write-string buffer target :start start :end end))))
+
+(defun flush-annotations (stream end truncatep)
+ (let ((end-posn (index-posn end stream)))
+ (loop
+ for annotation = (dequeue-annotation stream :end-posn end-posn)
+ while annotation
+ do (invoke-annotation stream annotation truncatep))))
+
+;;;
+;;; Changed functions
+;;;
+
+(defun maybe-output (stream force-newlines-p)
+ (declare (type pretty-stream stream))
+ (let ((tail (pretty-stream-queue-tail stream))
+ (output-anything nil))
+ (loop
+ (unless tail
+ (setf (pretty-stream-queue-head stream) nil)
+ (return))
+ (let ((next (pop tail)))
+ (etypecase next
+ (newline
+ (when (ecase (newline-kind next)
+ ((:literal :mandatory :linear) t)
+ (:miser (misering-p stream))
+ (:fill
+ (or (misering-p stream)
+ (> (pretty-stream-line-number stream)
+ (logical-block-section-start-line
+ (first (pretty-stream-blocks stream))))
+ (ecase (fits-on-line-p stream
+ (newline-section-end next)
+ force-newlines-p)
+ ((t) nil)
+ ((nil) t)
+ (:dont-know
+ (return))))))
+ (setf output-anything t)
+ (output-line stream next)))
+ (indentation
+ (unless (misering-p stream)
+ (set-indentation stream
+ (+ (ecase (indentation-kind next)
+ (:block
+ (logical-block-start-column
+ (car (pretty-stream-blocks stream))))
+ (:current
+ (posn-column
+ (indentation-posn next)
+ stream)))
+ (indentation-amount next)))))
+ (block-start
+ (ecase (fits-on-line-p stream (block-start-section-end next)
+ force-newlines-p)
+ ((t)
+ ;; Just nuke the whole logical block and make it look like one
+ ;; nice long literal. (But don't nuke annotations.)
+ (let ((end (block-start-block-end next)))
+ (expand-tabs stream end)
+ (re-enqueue-annotations stream end)
+ (setf tail (cdr (member end tail)))))
+ ((nil)
+ (really-start-logical-block
+ stream
+ (posn-column (block-start-posn next) stream)
+ (block-start-prefix next)
+ (block-start-suffix next)))
+ (:dont-know
+ (return))))
+ (block-end
+ (really-end-logical-block stream))
+ (tab
+ (expand-tabs stream next))
+ (annotation
+ (re-enqueue-annotation stream next))))
+ (setf (pretty-stream-queue-tail stream) tail))
+ output-anything))
+
+(defun output-line (stream until)
+ (declare (type pretty-stream stream)
+ (type newline until))
+ (let* ((target (pretty-stream-target stream))
+ (buffer (pretty-stream-buffer stream))
+ (kind (newline-kind until))
+ (literal-p (eq kind :literal))
+ (amount-to-consume (posn-index (newline-posn until) stream))
+ (amount-to-print
+ (if literal-p
+ amount-to-consume
+ (let ((last-non-blank
+ (position #\space buffer :end amount-to-consume
+ :from-end t :test #'char/=)))
+ (if last-non-blank
+ (1+ last-non-blank)
+ 0)))))
+ (output-buffer-with-annotations stream amount-to-print)
+ (flush-annotations stream amount-to-consume nil)
+ (let ((line-number (pretty-stream-line-number stream)))
+ (incf line-number)
+ (when (and (not *print-readably*)
+ (pretty-stream-print-lines stream)
+ (>= line-number (pretty-stream-print-lines stream)))
+ (write-string " .." target)
+ (flush-annotations stream
+ (pretty-stream-buffer-fill-pointer stream)
+ t)
+ (let ((suffix-length (logical-block-suffix-length
+ (car (pretty-stream-blocks stream)))))
+ (unless (zerop suffix-length)
+ (let* ((suffix (pretty-stream-suffix stream))
+ (len (length suffix)))
+ (write-string suffix target
+ :start (- len suffix-length)
+ :end len))))
+ (throw 'line-limit-abbreviation-happened t))
+ (setf (pretty-stream-line-number stream) line-number)
+ (write-char #\newline target)
+ (setf (pretty-stream-buffer-start-column stream) 0)
+ (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ (block (first (pretty-stream-blocks stream)))
+ (prefix-len
+ (if literal-p
+ (logical-block-per-line-prefix-end block)
+ (logical-block-prefix-length block)))
+ (shift (- amount-to-consume prefix-len))
+ (new-fill-ptr (- fill-ptr shift))
+ (new-buffer buffer)
+ (buffer-length (length buffer)))
+ (when (> new-fill-ptr buffer-length)
+ (setf new-buffer
+ (make-string (max (* buffer-length 2)
+ (+ buffer-length
+ (floor (* (- new-fill-ptr buffer-length)
+ 5)
+ 4)))))
+ (setf (pretty-stream-buffer stream) new-buffer))
+ (replace new-buffer buffer
+ :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
+ (replace new-buffer (pretty-stream-prefix stream)
+ :end1 prefix-len)
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (incf (pretty-stream-buffer-offset stream) shift)
+ (unless literal-p
+ (setf (logical-block-section-column block) prefix-len)
+ (setf (logical-block-section-start-line block) line-number))))))
+
+(defun output-partial-line (stream)
+ (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ (tail (pretty-stream-queue-tail stream))
+ (count
+ (if tail
+ (posn-index (queued-op-posn (car tail)) stream)
+ fill-ptr))
+ (new-fill-ptr (- fill-ptr count))
+ (buffer (pretty-stream-buffer stream)))
+ (when (zerop count)
+ (error "Output-partial-line called when nothing can be output."))
+ (output-buffer-with-annotations stream count)
+ (incf (pretty-stream-buffer-start-column stream) count)
+ (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (incf (pretty-stream-buffer-offset stream) count)))
+
+(defun force-pretty-output (stream)
+ (maybe-output stream nil)
+ (expand-tabs stream nil)
+ (re-enqueue-annotations stream nil)
+ (output-buffer-with-annotations stream
+ (pretty-stream-buffer-fill-pointer stream)))
+ \ No newline at end of file
diff --git a/vim/bundle/slimv/slime/slime.el b/vim/bundle/slimv/slime/slime.el
new file mode 100644
index 0000000..feca7e8
--- /dev/null
+++ b/vim/bundle/slimv/slime/slime.el
@@ -0,0 +1,7501 @@
+;;; slime.el --- Superior Lisp Interaction Mode for Emacs -*-lexical-binding:t-*-
+
+;; URL: https://github.com/slime/slime
+;; Package-Requires: ((cl-lib "0.5") (macrostep "0.9"))
+;; Keywords: languages, lisp, slime
+;; Version: 2.18
+
+;;;; License and Commentary
+
+;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller
+;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller
+;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler
+;;
+;; For a detailed list of contributors, see the manual.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public
+;; License along with this program; if not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+;; MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; SLIME is the ``Superior Lisp Interaction Mode for Emacs.''
+;;
+;; SLIME extends Emacs with support for interactive programming in
+;; Common Lisp. The features are centered around slime-mode, an Emacs
+;; minor-mode that complements the standard lisp-mode. While lisp-mode
+;; supports editing Lisp source files, slime-mode adds support for
+;; interacting with a running Common Lisp process for compilation,
+;; debugging, documentation lookup, and so on.
+;;
+;; The slime-mode programming environment follows the example of
+;; Emacs's native Emacs Lisp environment. We have also included good
+;; ideas from similar systems (such as ILISP) and some new ideas of
+;; our own.
+;;
+;; SLIME is constructed from two parts: a user-interface written in
+;; Emacs Lisp, and a supporting server program written in Common
+;; Lisp. The two sides are connected together with a socket and
+;; communicate using an RPC-like protocol.
+;;
+;; The Lisp server is primarily written in portable Common Lisp. The
+;; required implementation-specific functionality is specified by a
+;; well-defined interface and implemented separately for each Lisp
+;; implementation. This makes SLIME readily portable.
+
+;;; Code:
+
+
+;;;; Dependencies and setup
+(eval-and-compile
+ (require 'cl-lib nil t)
+ ;; For emacs 23, look for bundled version
+ (require 'cl-lib "lib/cl-lib"))
+
+(eval-when-compile (require 'cl)) ; defsetf, lexical-let
+
+(eval-and-compile
+ (if (< emacs-major-version 23)
+ (error "Slime requires an Emacs version of 23, or above")))
+
+(require 'hyperspec "lib/hyperspec")
+(require 'thingatpt)
+(require 'comint)
+(require 'pp)
+(require 'easymenu)
+(require 'outline)
+(require 'arc-mode)
+(require 'etags)
+(require 'compile)
+
+(eval-when-compile
+ (require 'apropos)
+ (require 'gud)
+ (require 'lisp-mnt))
+
+(declare-function lm-version "lisp-mnt")
+
+(defvar slime-path nil
+ "Directory containing the Slime package.
+This is used to load the supporting Common Lisp library, Swank.
+The default value is automatically computed from the location of
+the Emacs Lisp package.")
+(setq slime-path (file-name-directory load-file-name))
+
+(defvar slime-version nil
+ "The version of SLIME that you're using.")
+(setq slime-version
+ (eval-when-compile
+ (lm-version
+ (cl-find "slime.el"
+ (remove nil
+ (list load-file-name
+ (when (boundp 'byte-compile-current-file)
+ byte-compile-current-file)))
+ :key #'file-name-nondirectory
+ :test #'string-equal))))
+
+(defvar slime-lisp-modes '(lisp-mode))
+(defvar slime-contribs nil
+ "A list of contrib packages to load with SLIME.")
+(define-obsolete-variable-alias 'slime-setup-contribs
+'slime-contribs "2.3.2")
+
+(defun slime-setup (&optional contribs)
+ "Setup Emacs so that lisp-mode buffers always use SLIME.
+CONTRIBS is a list of contrib packages to load. If `nil', use
+`slime-contribs'. "
+ (interactive)
+ (when (member 'lisp-mode slime-lisp-modes)
+ (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook))
+ (when contribs
+ (setq slime-contribs contribs))
+ (slime--setup-contribs))
+
+(defvar slime-required-modules '())
+
+(defun slime--setup-contribs ()
+ "Load and initialize contribs."
+ (dolist (c slime-contribs)
+ (unless (featurep c)
+ (require c)
+ (let ((init (intern (format "%s-init" c))))
+ (when (fboundp init)
+ (funcall init))))))
+
+(defun slime-lisp-mode-hook ()
+ (slime-mode 1)
+ (set (make-local-variable 'lisp-indent-function)
+ 'common-lisp-indent-function))
+
+(defvar slime-protocol-version nil)
+(setq slime-protocol-version slime-version)
+
+
+;;;; Customize groups
+;;
+;;;;; slime
+
+(defgroup slime nil
+ "Interaction with the Superior Lisp Environment."
+ :prefix "slime-"
+ :group 'applications)
+
+;;;;; slime-ui
+
+(defgroup slime-ui nil
+ "Interaction with the Superior Lisp Environment."
+ :prefix "slime-"
+ :group 'slime)
+
+(defcustom slime-truncate-lines t
+ "Set `truncate-lines' in popup buffers.
+This applies to buffers that present lines as rows of data, such as
+debugger backtraces and apropos listings."
+ :type 'boolean
+ :group 'slime-ui)
+
+(defcustom slime-kill-without-query-p nil
+ "If non-nil, kill SLIME processes without query when quitting Emacs.
+This applies to the *inferior-lisp* buffer and the network connections."
+ :type 'boolean
+ :group 'slime-ui)
+
+;;;;; slime-lisp
+
+(defgroup slime-lisp nil
+ "Lisp server configuration."
+ :prefix "slime-"
+ :group 'slime)
+
+(defcustom slime-backend "swank-loader.lisp"
+ "The name of the Lisp file that loads the Swank server.
+This name is interpreted relative to the directory containing
+slime.el, but could also be set to an absolute filename."
+ :type 'string
+ :group 'slime-lisp)
+
+(defcustom slime-connected-hook nil
+ "List of functions to call when SLIME connects to Lisp."
+ :type 'hook
+ :group 'slime-lisp)
+
+(defcustom slime-enable-evaluate-in-emacs nil
+ "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs.
+The default is nil, as this feature can be a security risk."
+ :type '(boolean)
+ :group 'slime-lisp)
+
+(defcustom slime-lisp-host "127.0.0.1"
+ "The default hostname (or IP address) to connect to."
+ :type 'string
+ :group 'slime-lisp)
+
+(defcustom slime-port 4005
+ "Port to use as the default for `slime-connect'."
+ :type 'integer
+ :group 'slime-lisp)
+
+(defvar slime-connect-host-history (list slime-lisp-host))
+(defvar slime-connect-port-history (list (prin1-to-string slime-port)))
+
+(defvar slime-net-valid-coding-systems
+ '((iso-latin-1-unix nil "iso-latin-1-unix")
+ (iso-8859-1-unix nil "iso-latin-1-unix")
+ (binary nil "iso-latin-1-unix")
+ (utf-8-unix t "utf-8-unix")
+ (emacs-mule-unix t "emacs-mule-unix")
+ (euc-jp-unix t "euc-jp-unix"))
+ "A list of valid coding systems.
+Each element is of the form: (NAME MULTIBYTEP CL-NAME)")
+
+(defun slime-find-coding-system (name)
+ "Return the coding system for the symbol NAME.
+The result is either an element in `slime-net-valid-coding-systems'
+of nil."
+ (let ((probe (assq name slime-net-valid-coding-systems)))
+ (when (and probe (if (fboundp 'check-coding-system)
+ (ignore-errors (check-coding-system (car probe)))
+ (eq (car probe) 'binary)))
+ probe)))
+
+(defcustom slime-net-coding-system
+ (car (cl-find-if 'slime-find-coding-system
+ slime-net-valid-coding-systems :key 'car))
+ "Coding system used for network connections.
+See also `slime-net-valid-coding-systems'."
+ :type (cons 'choice
+ (mapcar (lambda (x)
+ (list 'const (car x)))
+ slime-net-valid-coding-systems))
+ :group 'slime-lisp)
+
+;;;;; slime-mode
+
+(defgroup slime-mode nil
+ "Settings for slime-mode Lisp source buffers."
+ :prefix "slime-"
+ :group 'slime)
+
+(defcustom slime-find-definitions-function 'slime-find-definitions-rpc
+ "Function to find definitions for a name.
+The function is called with the definition name, a string, as its
+argument."
+ :type 'function
+ :group 'slime-mode
+ :options '(slime-find-definitions-rpc
+ slime-etags-definitions
+ (lambda (name)
+ (append (slime-find-definitions-rpc name)
+ (slime-etags-definitions name)))
+ (lambda (name)
+ (or (slime-find-definitions-rpc name)
+ (and tags-table-list
+ (slime-etags-definitions name))))))
+
+;; FIXME: remove one day
+(defcustom slime-complete-symbol-function 'nil
+ "Obsolete. Use `slime-completion-at-point-functions' instead."
+ :group 'slime-mode
+ :type '(choice (const :tag "Compound" slime-complete-symbol*)
+ (const :tag "Fuzzy" slime-fuzzy-complete-symbol)))
+
+(make-obsolete-variable 'slime-complete-symbol-function
+ 'slime-completion-at-point-functions
+ "2015-10-18")
+
+(defcustom slime-completion-at-point-functions
+ '(slime-filename-completion
+ slime-simple-completion-at-point)
+ "List of functions to perform completion.
+Works like `completion-at-point-functions'.
+`slime--completion-at-point' uses this variable."
+ :group 'slime-mode)
+
+;;;;; slime-mode-faces
+
+(defgroup slime-mode-faces nil
+ "Faces in slime-mode source code buffers."
+ :prefix "slime-"
+ :group 'slime-mode)
+
+(defface slime-error-face
+ `((((class color) (background light))
+ (:underline "red"))
+ (((class color) (background dark))
+ (:underline "red"))
+ (t (:underline t)))
+ "Face for errors from the compiler."
+ :group 'slime-mode-faces)
+
+(defface slime-warning-face
+ `((((class color) (background light))
+ (:underline "orange"))
+ (((class color) (background dark))
+ (:underline "coral"))
+ (t (:underline t)))
+ "Face for warnings from the compiler."
+ :group 'slime-mode-faces)
+
+(defface slime-style-warning-face
+ `((((class color) (background light))
+ (:underline "brown"))
+ (((class color) (background dark))
+ (:underline "gold"))
+ (t (:underline t)))
+ "Face for style-warnings from the compiler."
+ :group 'slime-mode-faces)
+
+(defface slime-note-face
+ `((((class color) (background light))
+ (:underline "brown4"))
+ (((class color) (background dark))
+ (:underline "light goldenrod"))
+ (t (:underline t)))
+ "Face for notes from the compiler."
+ :group 'slime-mode-faces)
+
+(defface slime-highlight-face
+ '((t (:inherit highlight :underline nil)))
+ "Face for compiler notes while selected."
+ :group 'slime-mode-faces)
+
+;;;;; sldb
+
+(defgroup slime-debugger nil
+ "Backtrace options and fontification."
+ :prefix "sldb-"
+ :group 'slime)
+
+(defmacro define-sldb-faces (&rest faces)
+ "Define the set of SLDB faces.
+Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES).
+NAME is a symbol; the face will be called sldb-NAME-face.
+DESCRIPTION is a one-liner for the customization buffer.
+PROPERTIES specifies any default face properties."
+ `(progn ,@(cl-loop for face in faces
+ collect `(define-sldb-face ,@face))))
+
+(defmacro define-sldb-face (name description &optional default)
+ (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))))
+ `(defface ,facename
+ (list (list t ,default))
+ ,(format "Face for %s." description)
+ :group 'slime-debugger)))
+
+(define-sldb-faces
+ (topline "the top line describing the error")
+ (condition "the condition class"
+ '(:inherit font-lock-warning-face))
+ (section "the labels of major sections in the debugger buffer"
+ '(:inherit header-line))
+ (frame-label "backtrace frame numbers"
+ '(:inherit shadow))
+ (restart-type "restart names."
+ '(:inherit font-lock-keyword-face))
+ (restart "restart descriptions")
+ (restart-number "restart numbers (correspond to keystrokes to invoke)"
+ '(:bold t))
+ (frame-line "function names and arguments in the backtrace")
+ (restartable-frame-line
+ "frames which are surely restartable"
+ '(:foreground "lime green"))
+ (non-restartable-frame-line
+ "frames which are surely not restartable")
+ (detailed-frame-line
+ "function names and arguments in a detailed (expanded) frame")
+ (local-name "local variable names"
+ '(:inherit font-lock-variable-name-face))
+ (local-value "local variable values")
+ (catch-tag "catch tags"
+ '(:inherit highlight)))
+
+
+;;;; Minor modes
+
+;;;;; slime-mode
+
+(defvar slime-mode-indirect-map (make-sparse-keymap)
+ "Empty keymap which has `slime-mode-map' as it's parent.
+This is a hack so that we can reinitilize the real slime-mode-map
+more easily. See `slime-init-keymaps'.")
+
+(defvar slime-buffer-connection)
+(defvar slime-dispatching-connection)
+(defvar slime-current-thread)
+
+(defun slime--on ()
+ (slime-setup-completion))
+
+(defun slime--off ()
+ (remove-hook 'completion-at-point-functions #'slime--completion-at-point t))
+
+(define-minor-mode slime-mode
+ "\\<slime-mode-map>\
+SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode).
+
+Commands to compile the current buffer's source file and visually
+highlight any resulting compiler notes and warnings:
+\\[slime-compile-and-load-file] - Compile and load the current buffer's file.
+\\[slime-compile-file] - Compile (but not load) the current buffer's file.
+\\[slime-compile-defun] - Compile the top-level form at point.
+
+Commands for visiting compiler notes:
+\\[slime-next-note] - Goto the next form with a compiler note.
+\\[slime-previous-note] - Goto the previous form with a compiler note.
+\\[slime-remove-notes] - Remove compiler-note annotations in buffer.
+
+Finding definitions:
+\\[slime-edit-definition]
+- Edit the definition of the function called at point.
+\\[slime-pop-find-definition-stack]
+- Pop the definition stack to go back from a definition.
+
+Documentation commands:
+\\[slime-describe-symbol] - Describe symbol.
+\\[slime-apropos] - Apropos search.
+\\[slime-disassemble-symbol] - Disassemble a function.
+
+Evaluation commands:
+\\[slime-eval-defun] - Evaluate top-level from containing point.
+\\[slime-eval-last-expression] - Evaluate sexp before point.
+\\[slime-pprint-eval-last-expression] \
+- Evaluate sexp before point, pretty-print result.
+
+Full set of commands:
+\\{slime-mode-map}"
+ :keymap slime-mode-indirect-map
+ :lighter (:eval (slime-modeline-string))
+ (cond (slime-mode (slime--on))
+ (t (slime--off))))
+
+
+;;;;;; Modeline
+
+(defun slime-modeline-string ()
+ "Return the string to display in the modeline.
+\"Slime\" only appears if we aren't connected. If connected,
+include package-name, connection-name, and possibly some state
+information."
+ (let ((conn (slime-current-connection)))
+ ;; Bail out early in case there's no connection, so we won't
+ ;; implicitly invoke `slime-connection' which may query the user.
+ (if (not conn)
+ (and slime-mode " Slime")
+ (let ((local (eq conn slime-buffer-connection))
+ (pkg (slime-current-package)))
+ (concat " "
+ (if local "{" "[")
+ (if pkg (slime-pretty-package-name pkg) "?")
+ " "
+ ;; ignore errors for closed connections
+ (ignore-errors (slime-connection-name conn))
+ (slime-modeline-state-string conn)
+ (if local "}" "]"))))))
+
+(defun slime-pretty-package-name (name)
+ "Return a pretty version of a package name NAME."
+ (cond ((string-match "^#?:\\(.*\\)$" name)
+ (match-string 1 name))
+ ((string-match "^\"\\(.*\\)\"$" name)
+ (match-string 1 name))
+ (t name)))
+
+(defun slime-modeline-state-string (conn)
+ "Return a string possibly describing CONN's state."
+ (cond ((not (eq (process-status conn) 'open))
+ (format " %s" (process-status conn)))
+ ((let ((pending (length (slime-rex-continuations conn)))
+ (sldbs (length (sldb-buffers conn))))
+ (cond ((and (zerop sldbs) (zerop pending)) nil)
+ ((zerop sldbs) (format " %s" pending))
+ (t (format " %s/%s" pending sldbs)))))))
+
+(defun slime--recompute-modelines ()
+ (force-mode-line-update t))
+
+
+;;;;; Key bindings
+
+(defvar slime-parent-map nil
+ "Parent keymap for shared between all Slime related modes.")
+
+(defvar slime-parent-bindings
+ '(("\M-." slime-edit-definition)
+ ("\M-," slime-pop-find-definition-stack)
+ ("\M-_" slime-edit-uses) ; for German layout
+ ("\M-?" slime-edit-uses) ; for USian layout
+ ("\C-x4." slime-edit-definition-other-window)
+ ("\C-x5." slime-edit-definition-other-frame)
+ ("\C-x\C-e" slime-eval-last-expression)
+ ("\C-\M-x" slime-eval-defun)
+ ;; Include PREFIX keys...
+ ("\C-c" slime-prefix-map)))
+
+(defvar slime-prefix-map nil
+ "Keymap for commands prefixed with `slime-prefix-key'.")
+
+(defvar slime-prefix-bindings
+ '(("\C-r" slime-eval-region)
+ (":" slime-interactive-eval)
+ ("\C-e" slime-interactive-eval)
+ ("E" slime-edit-value)
+ ("\C-l" slime-load-file)
+ ("\C-b" slime-interrupt)
+ ("\M-d" slime-disassemble-symbol)
+ ("\C-t" slime-toggle-trace-fdefinition)
+ ("I" slime-inspect)
+ ("\C-xt" slime-list-threads)
+ ("\C-xn" slime-next-connection)
+ ("\C-xp" slime-prev-connection)
+ ("\C-xc" slime-list-connections)
+ ("<" slime-list-callers)
+ (">" slime-list-callees)
+ ;; Include DOC keys...
+ ("\C-d" slime-doc-map)
+ ;; Include XREF WHO-FOO keys...
+ ("\C-w" slime-who-map)
+ ))
+
+(defvar slime-editing-map nil
+ "These keys are useful for buffers where the user can insert and
+edit s-exprs, e.g. for source buffers and the REPL.")
+
+(defvar slime-editing-keys
+ `(;; Arglist display & completion
+ (" " slime-space)
+ ;; Evaluating
+ ;;("\C-x\M-e" slime-eval-last-expression-display-output :inferior t)
+ ("\C-c\C-p" slime-pprint-eval-last-expression)
+ ;; Macroexpand
+ ("\C-c\C-m" slime-expand-1)
+ ("\C-c\M-m" slime-macroexpand-all)
+ ;; Misc
+ ("\C-c\C-u" slime-undefine-function)
+ (,(kbd "C-M-.") slime-next-location)
+ (,(kbd "C-M-,") slime-previous-location)
+ ;; Obsolete, redundant bindings
+ ("\C-c\C-i" completion-at-point)
+ ;;("\M-*" pop-tag-mark) ; almost to clever
+ ))
+
+(defvar slime-mode-map nil
+ "Keymap for slime-mode.")
+
+(defvar slime-keys
+ '( ;; Compiler notes
+ ("\M-p" slime-previous-note)
+ ("\M-n" slime-next-note)
+ ("\C-c\M-c" slime-remove-notes)
+ ("\C-c\C-k" slime-compile-and-load-file)
+ ("\C-c\M-k" slime-compile-file)
+ ("\C-c\C-c" slime-compile-defun)))
+
+(defun slime-nop ()
+ "The null command. Used to shadow currently-unused keybindings."
+ (interactive)
+ (call-interactively 'undefined))
+
+(defvar slime-doc-map nil
+ "Keymap for documentation commands. Bound to a prefix key.")
+
+(defvar slime-doc-bindings
+ '((?a slime-apropos)
+ (?z slime-apropos-all)
+ (?p slime-apropos-package)
+ (?d slime-describe-symbol)
+ (?f slime-describe-function)
+ (?h slime-documentation-lookup)
+ (?~ common-lisp-hyperspec-format)
+ (?g common-lisp-hyperspec-glossary-term)
+ (?# common-lisp-hyperspec-lookup-reader-macro)))
+
+(defvar slime-who-map nil
+ "Keymap for who-xref commands. Bound to a prefix key.")
+
+(defvar slime-who-bindings
+ '((?c slime-who-calls)
+ (?w slime-calls-who)
+ (?r slime-who-references)
+ (?b slime-who-binds)
+ (?s slime-who-sets)
+ (?m slime-who-macroexpands)
+ (?a slime-who-specializes)))
+
+(defun slime-init-keymaps ()
+ "(Re)initialize the keymaps for `slime-mode'."
+ (interactive)
+ (slime-init-keymap 'slime-doc-map t t slime-doc-bindings)
+ (slime-init-keymap 'slime-who-map t t slime-who-bindings)
+ (slime-init-keymap 'slime-prefix-map t nil slime-prefix-bindings)
+ (slime-init-keymap 'slime-parent-map nil nil slime-parent-bindings)
+ (slime-init-keymap 'slime-editing-map nil nil slime-editing-keys)
+ (set-keymap-parent slime-editing-map slime-parent-map)
+ (slime-init-keymap 'slime-mode-map nil nil slime-keys)
+ (set-keymap-parent slime-mode-map slime-editing-map)
+ (set-keymap-parent slime-mode-indirect-map slime-mode-map))
+
+(defun slime-init-keymap (keymap-name prefixp bothp bindings)
+ (set keymap-name (make-sparse-keymap))
+ (when prefixp (define-prefix-command keymap-name))
+ (slime-bind-keys (eval keymap-name) bothp bindings))
+
+(defun slime-bind-keys (keymap bothp bindings)
+ "Add BINDINGS to KEYMAP.
+If BOTHP is true also add bindings with control modifier."
+ (cl-loop for (key command) in bindings do
+ (cond (bothp
+ (define-key keymap `[,key] command)
+ (unless (equal key ?h) ; But don't bind C-h
+ (define-key keymap `[(control ,key)] command)))
+ (t (define-key keymap key command)))))
+
+(slime-init-keymaps)
+
+(define-minor-mode slime-editing-mode
+ "Minor mode which makes slime-editing-map available.
+\\{slime-editing-map}"
+ nil
+ nil
+ slime-editing-map)
+
+
+;;;; Framework'ey bits
+;;;
+;;; This section contains some standard SLIME idioms: basic macros,
+;;; ways of showing messages to the user, etc. All the code in this
+;;; file should use these functions when applicable.
+;;;
+;;;;; Syntactic sugar
+
+(defmacro slime-dcase (value &rest patterns)
+ (declare (indent 1))
+ "Dispatch VALUE to one of PATTERNS.
+A cross between `case' and `destructuring-bind'.
+The pattern syntax is:
+ ((HEAD . ARGS) . BODY)
+The list of patterns is searched for a HEAD `eq' to the car of
+VALUE. If one is found, the BODY is executed with ARGS bound to the
+corresponding values in the CDR of VALUE."
+ (let ((operator (cl-gensym "op-"))
+ (operands (cl-gensym "rand-"))
+ (tmp (cl-gensym "tmp-")))
+ `(let* ((,tmp ,value)
+ (,operator (car ,tmp))
+ (,operands (cdr ,tmp)))
+ (cl-case ,operator
+ ,@(mapcar (lambda (clause)
+ (if (eq (car clause) t)
+ `(t ,@(cdr clause))
+ (cl-destructuring-bind ((op &rest rands) &rest body)
+ clause
+ `(,op (cl-destructuring-bind ,rands ,operands
+ . ,(or body
+ '((ignore)) ; suppress some warnings
+ ))))))
+ patterns)
+ ,@(if (eq (caar (last patterns)) t)
+ '()
+ `((t (error "slime-dcase failed: %S" ,tmp))))))))
+
+(defmacro slime-define-keys (keymap &rest key-command)
+ "Define keys in KEYMAP. Each KEY-COMMAND is a list of (KEY COMMAND)."
+ (declare (indent 1))
+ `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c))
+ key-command)))
+
+(cl-defmacro with-struct ((conc-name &rest slots) struct &body body)
+ "Like with-slots but works only for structs.
+\(fn (CONC-NAME &rest SLOTS) STRUCT &body BODY)"
+ (declare (indent 2))
+ (let ((struct-var (cl-gensym "struct"))
+ (reader (lambda (slot)
+ (intern (concat (symbol-name conc-name)
+ (symbol-name slot))))))
+ `(let ((,struct-var ,struct))
+ (cl-symbol-macrolet
+ ,(mapcar (lambda (slot)
+ (cl-etypecase slot
+ (symbol `(,slot (,(funcall reader slot) ,struct-var)))
+ (cons `(,(cl-first slot)
+ (,(funcall reader (cl-second slot))
+ ,struct-var)))))
+ slots)
+ . ,body))))
+
+;;;;; Very-commonly-used functions
+
+(defvar slime-message-function 'message)
+
+;; Interface
+(defun slime-buffer-name (type &optional hidden)
+ (cl-assert (keywordp type))
+ (concat (if hidden " " "")
+ (format "*slime-%s*" (substring (symbol-name type) 1))))
+
+;; Interface
+(defun slime-message (format &rest args)
+ "Like `message' but with special support for multi-line messages.
+Single-line messages use the echo area."
+ (apply slime-message-function format args))
+
+(defun slime-display-warning (message &rest args)
+ (display-warning '(slime warning) (apply #'format message args)))
+
+(defvar slime-background-message-function 'slime-display-oneliner)
+
+;; Interface
+(defun slime-background-message (format-string &rest format-args)
+ "Display a message in passing.
+This is like `slime-message', but less distracting because it
+will never pop up a buffer or display multi-line messages.
+It should be used for \"background\" messages such as argument lists."
+ (apply slime-background-message-function format-string format-args))
+
+(defun slime-display-oneliner (format-string &rest format-args)
+ (let* ((msg (apply #'format format-string format-args)))
+ (unless (minibuffer-window-active-p (minibuffer-window))
+ (message "%s" (slime-oneliner msg)))))
+
+(defun slime-oneliner (string)
+ "Return STRING truncated to fit in a single echo-area line."
+ (substring string 0 (min (length string)
+ (or (cl-position ?\n string) most-positive-fixnum)
+ (1- (window-width (minibuffer-window))))))
+
+;; Interface
+(defun slime-set-truncate-lines ()
+ "Apply `slime-truncate-lines' to the current buffer."
+ (when slime-truncate-lines
+ (set (make-local-variable 'truncate-lines) t)))
+
+;; Interface
+(defun slime-read-package-name (prompt &optional initial-value)
+ "Read a package name from the minibuffer, prompting with PROMPT."
+ (let ((completion-ignore-case t))
+ (completing-read prompt (slime-bogus-completion-alist
+ (slime-eval
+ `(swank:list-all-package-names t)))
+ nil t initial-value)))
+
+;; Interface
+(defun slime-read-symbol-name (prompt &optional query)
+ "Either read a symbol name or choose the one at point.
+The user is prompted if a prefix argument is in effect, if there is no
+symbol at point, or if QUERY is non-nil."
+ (cond ((or current-prefix-arg query (not (slime-symbol-at-point)))
+ (slime-read-from-minibuffer prompt (slime-symbol-at-point)))
+ (t (slime-symbol-at-point))))
+
+;; Interface
+(defmacro slime-propertize-region (props &rest body)
+ "Execute BODY and add PROPS to all the text it inserts.
+More precisely, PROPS are added to the region between the point's
+positions before and after executing BODY."
+ (declare (indent 1) (debug (sexp &rest form)))
+ (let ((start (cl-gensym)))
+ `(let ((,start (point)))
+ (prog1 (progn ,@body)
+ (add-text-properties ,start (point) ,props)))))
+
+(defun slime-add-face (face string)
+ (declare (indent 1))
+ (add-text-properties 0 (length string) (list 'face face) string)
+ string)
+
+;; Interface
+(defsubst slime-insert-propertized (props &rest args)
+ "Insert all ARGS and then add text-PROPS to the inserted text."
+ (slime-propertize-region props (apply #'insert args)))
+
+(defmacro slime-with-rigid-indentation (level &rest body)
+ "Execute BODY and then rigidly indent its text insertions.
+Assumes all insertions are made at point."
+ (declare (indent 1))
+ (let ((start (cl-gensym)) (l (cl-gensym)))
+ `(let ((,start (point)) (,l ,(or level '(current-column))))
+ (prog1 (progn ,@body)
+ (slime-indent-rigidly ,start (point) ,l)))))
+
+(defun slime-indent-rigidly (start end column)
+ ;; Similar to `indent-rigidly' but doesn't inherit text props.
+ (let ((indent (make-string column ?\ )))
+ (save-excursion
+ (goto-char end)
+ (beginning-of-line)
+ (while (and (<= start (point))
+ (progn
+ (insert-before-markers indent)
+ (zerop (forward-line -1))))))))
+
+(defun slime-insert-indented (&rest strings)
+ "Insert all arguments rigidly indented."
+ (slime-with-rigid-indentation nil
+ (apply #'insert strings)))
+
+(defun slime-property-bounds (prop)
+ "Return two the positions of the previous and next changes to PROP.
+PROP is the name of a text property."
+ (cl-assert (get-text-property (point) prop))
+ (let ((end (next-single-char-property-change (point) prop)))
+ (list (previous-single-char-property-change end prop) end)))
+
+(defun slime-curry (fun &rest args)
+ "Partially apply FUN to ARGS. The result is a new function.
+This idiom is preferred over `lexical-let'."
+ `(lambda (&rest more) (apply ',fun (append ',args more))))
+
+(defun slime-rcurry (fun &rest args)
+ "Like `slime-curry' but ARGS on the right are applied."
+ `(lambda (&rest more) (apply ',fun (append more ',args))))
+
+
+;;;;; Temporary popup buffers
+
+;; keep compiler quiet
+(defvar slime-buffer-package)
+(defvar slime-buffer-connection)
+
+;; Interface
+(cl-defmacro slime-with-popup-buffer ((name &key package connection select
+ mode)
+ &body body)
+ "Similar to `with-output-to-temp-buffer'.
+Bind standard-output and initialize some buffer-local variables.
+Restore window configuration when closed.
+
+NAME is the name of the buffer to be created.
+PACKAGE is the value `slime-buffer-package'.
+CONNECTION is the value for `slime-buffer-connection',
+ if nil, no explicit connection is associated with
+ the buffer. If t, the current connection is taken.
+MODE is the name of a major mode which will be enabled.
+"
+ (declare (indent 1))
+ (let ((package-sym (cl-gensym "package-"))
+ (connection-sym (cl-gensym "connection-")))
+ `(let ((,package-sym ,(if (eq package t)
+ `(slime-current-package)
+ package))
+ (,connection-sym ,(if (eq connection t)
+ `(slime-current-connection)
+ connection)))
+ (with-current-buffer (get-buffer-create ,name)
+ (let ((inhibit-read-only t)
+ (standard-output (current-buffer)))
+ (erase-buffer)
+ (funcall (or ,mode 'fundamental-mode))
+ (setq slime-buffer-package ,package-sym
+ slime-buffer-connection ,connection-sym)
+ (set-syntax-table lisp-mode-syntax-table)
+ ,@body
+ (slime-popup-buffer-mode 1)
+ (funcall (if ,select 'pop-to-buffer 'display-buffer)
+ (current-buffer))
+ (current-buffer))))))
+
+(defvar slime-popup-buffer-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "q") 'quit-window)
+ ;;("\C-c\C-z" . slime-switch-to-output-buffer)
+ (define-key map (kbd "M-.") 'slime-edit-definition)
+ map))
+
+(define-minor-mode slime-popup-buffer-mode
+ "Mode for displaying read only stuff"
+ nil nil nil
+ (setq buffer-read-only t))
+
+(add-to-list 'minor-mode-alist
+ `(slime-popup-buffer-mode
+ (:eval (unless slime-mode
+ (slime-modeline-string)))))
+
+(set-keymap-parent slime-popup-buffer-mode-map slime-parent-map)
+
+;;;;; Filename translation
+;;;
+;;; Filenames passed between Emacs and Lisp should be translated using
+;;; these functions. This way users who run Emacs and Lisp on separate
+;;; machines have a chance to integrate file operations somehow.
+
+(defvar slime-to-lisp-filename-function #'convert-standard-filename
+ "Function to translate Emacs filenames to CL namestrings.")
+(defvar slime-from-lisp-filename-function #'identity
+ "Function to translate CL namestrings to Emacs filenames.")
+
+(defun slime-to-lisp-filename (filename)
+ "Translate the string FILENAME to a Lisp filename."
+ (funcall slime-to-lisp-filename-function filename))
+
+(defun slime-from-lisp-filename (filename)
+ "Translate the Lisp filename FILENAME to an Emacs filename."
+ (funcall slime-from-lisp-filename-function filename))
+
+
+;;;; Starting SLIME
+;;;
+;;; This section covers starting an inferior-lisp, compiling and
+;;; starting the server, initiating a network connection.
+
+;;;;; Entry points
+
+;; We no longer load inf-lisp, but we use this variable for backward
+;; compatibility.
+(defvar inferior-lisp-program "lisp"
+ "*Program name for invoking an inferior Lisp with for Inferior Lisp mode.")
+
+(defvar slime-lisp-implementations nil
+ "*A list of known Lisp implementations.
+The list should have the form:
+ ((NAME (PROGRAM PROGRAM-ARGS...) &key KEYWORD-ARGS) ...)
+
+NAME is a symbol for the implementation.
+PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process.
+For KEYWORD-ARGS see `slime-start'.
+
+Here's an example:
+ ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init slime-init-command)
+ (acl (\"acl7\") :coding-system emacs-mule))")
+
+(defvar slime-default-lisp nil
+ "*The name of the default Lisp implementation.
+See `slime-lisp-implementations'")
+
+;; dummy definitions for the compiler
+(defvar slime-net-processes)
+(defvar slime-default-connection)
+
+(defun slime (&optional command coding-system)
+ "Start an inferior^_superior Lisp and connect to its Swank server."
+ (interactive)
+ (slime-setup)
+ (let ((inferior-lisp-program (or command inferior-lisp-program))
+ (slime-net-coding-system (or coding-system slime-net-coding-system)))
+ (slime-start* (cond ((and command (symbolp command))
+ (slime-lisp-options command))
+ (t (slime-read-interactive-args))))))
+
+(defvar slime-inferior-lisp-program-history '()
+ "History list of command strings. Used by `slime'.")
+
+(defun slime-read-interactive-args ()
+ "Return the list of args which should be passed to `slime-start'.
+
+The rules for selecting the arguments are rather complicated:
+
+- In the most common case, i.e. if there's no prefix-arg in
+ effect and if `slime-lisp-implementations' is nil, use
+ `inferior-lisp-program' as fallback.
+
+- If the table `slime-lisp-implementations' is non-nil use the
+ implementation with name `slime-default-lisp' or if that's nil
+ the first entry in the table.
+
+- If the prefix-arg is `-', prompt for one of the registered
+ lisps.
+
+- If the prefix-arg is positive, read the command to start the
+ process."
+ (let ((table slime-lisp-implementations))
+ (cond ((not current-prefix-arg) (slime-lisp-options))
+ ((eq current-prefix-arg '-)
+ (let ((key (completing-read
+ "Lisp name: " (mapcar (lambda (x)
+ (list (symbol-name (car x))))
+ table)
+ nil t)))
+ (slime-lookup-lisp-implementation table (intern key))))
+ (t
+ (cl-destructuring-bind (program &rest program-args)
+ (split-string-and-unquote
+ (read-shell-command "Run lisp: " inferior-lisp-program
+ 'slime-inferior-lisp-program-history))
+ (let ((coding-system
+ (if (eq 16 (prefix-numeric-value current-prefix-arg))
+ (read-coding-system "set slime-coding-system: "
+ slime-net-coding-system)
+ slime-net-coding-system)))
+ (list :program program :program-args program-args
+ :coding-system coding-system)))))))
+
+(defun slime-lisp-options (&optional name)
+ (let ((table slime-lisp-implementations))
+ (cl-assert (or (not name) table))
+ (cond (table (slime-lookup-lisp-implementation slime-lisp-implementations
+ (or name slime-default-lisp
+ (car (car table)))))
+ (t (cl-destructuring-bind (program &rest args)
+ (split-string inferior-lisp-program)
+ (list :program program :program-args args))))))
+
+(defun slime-lookup-lisp-implementation (table name)
+ (let ((arguments (cl-rest (assoc name table))))
+ (unless arguments
+ (error "Could not find lisp implementation with the name '%S'" name))
+ (when (and (= (length arguments) 1)
+ (functionp (cl-first arguments)))
+ (setf arguments (funcall (cl-first arguments))))
+ (cl-destructuring-bind ((prog &rest args) &rest keys) arguments
+ (cl-list* :name name :program prog :program-args args keys))))
+
+(cl-defun slime-start (&key (program inferior-lisp-program) program-args
+ directory
+ (coding-system slime-net-coding-system)
+ (init 'slime-init-command)
+ name
+ (buffer "*inferior-lisp*")
+ init-function
+ env)
+ "Start a Lisp process and connect to it.
+This function is intended for programmatic use if `slime' is not
+flexible enough.
+
+PROGRAM and PROGRAM-ARGS are the filename and argument strings
+ for the subprocess.
+INIT is a function that should return a string to load and start
+ Swank. The function will be called with the PORT-FILENAME and ENCODING as
+ arguments. INIT defaults to `slime-init-command'.
+CODING-SYSTEM a symbol for the coding system. The default is
+ slime-net-coding-system
+ENV environment variables for the subprocess (see `process-environment').
+INIT-FUNCTION function to call right after the connection is established.
+BUFFER the name of the buffer to use for the subprocess.
+NAME a symbol to describe the Lisp implementation
+DIRECTORY change to this directory before starting the process.
+"
+ (let ((args (list :program program :program-args program-args :buffer buffer
+ :coding-system coding-system :init init :name name
+ :init-function init-function :env env)))
+ (slime-check-coding-system coding-system)
+ (when (slime-bytecode-stale-p)
+ (slime-urge-bytecode-recompile))
+ (let ((proc (slime-maybe-start-lisp program program-args env
+ directory buffer)))
+ (slime-inferior-connect proc args)
+ (pop-to-buffer (process-buffer proc)))))
+
+(defun slime-start* (options)
+ (apply #'slime-start options))
+
+(defun slime-connect (host port &optional _coding-system interactive-p)
+ "Connect to a running Swank server. Return the connection."
+ (interactive (list (read-from-minibuffer
+ "Host: " (cl-first slime-connect-host-history)
+ nil nil '(slime-connect-host-history . 1))
+ (string-to-number
+ (read-from-minibuffer
+ "Port: " (cl-first slime-connect-port-history)
+ nil nil '(slime-connect-port-history . 1)))
+ nil t))
+ (slime-setup)
+ (when (and interactive-p
+ slime-net-processes
+ (y-or-n-p "Close old connections first? "))
+ (slime-disconnect-all))
+ (message "Connecting to Swank on port %S.." port)
+ (let* ((process (slime-net-connect host port))
+ (slime-dispatching-connection process))
+ (slime-setup-connection process)))
+
+;; FIXME: seems redundant
+(defun slime-start-and-init (options fun)
+ (let* ((rest (plist-get options :init-function))
+ (init (cond (rest `(lambda () (funcall ',rest) (funcall ',fun)))
+ (t fun))))
+ (slime-start* (plist-put (cl-copy-list options) :init-function init))))
+
+;;;;; Start inferior lisp
+;;;
+;;; Here is the protocol for starting SLIME:
+;;;
+;;; 0. Emacs recompiles/reloads slime.elc if it exists and is stale.
+;;; 1. Emacs starts an inferior Lisp process.
+;;; 2. Emacs tells Lisp (via stdio) to load and start Swank.
+;;; 3. Lisp recompiles the Swank if needed.
+;;; 4. Lisp starts the Swank server and writes its TCP port to a temp file.
+;;; 5. Emacs reads the temp file to get the port and then connects.
+;;; 6. Emacs prints a message of warm encouragement for the hacking ahead.
+;;;
+;;; Between steps 2-5 Emacs polls for the creation of the temp file so
+;;; that it can make the connection. This polling may continue for a
+;;; fair while if Swank needs recompilation.
+
+(defvar slime-connect-retry-timer nil
+ "Timer object while waiting for an inferior-lisp to start.")
+
+;;; Recompiling bytecode:
+
+(defun slime-bytecode-stale-p ()
+ "Return true if slime.elc is older than slime.el."
+ (let ((libfile (locate-library "slime")))
+ (when libfile
+ (let* ((basename (file-name-sans-extension libfile))
+ (sourcefile (concat basename ".el"))
+ (bytefile (concat basename ".elc")))
+ (and (file-exists-p bytefile)
+ (file-newer-than-file-p sourcefile bytefile))))))
+
+(defun slime-recompile-bytecode ()
+ "Recompile and reload slime."
+ (interactive)
+ (let ((sourcefile (concat (file-name-sans-extension (locate-library "slime"))
+ ".el")))
+ (byte-compile-file sourcefile t)))
+
+(defun slime-urge-bytecode-recompile ()
+ "Urge the user to recompile slime.elc.
+Return true if we have been given permission to continue."
+ (when (y-or-n-p "slime.elc is older than source. Recompile first? ")
+ (slime-recompile-bytecode)))
+
+(defun slime-abort-connection ()
+ "Abort connection the current connection attempt."
+ (interactive)
+ (cond (slime-connect-retry-timer
+ (slime-cancel-connect-retry-timer)
+ (message "Cancelled connection attempt."))
+ (t (error "Not connecting"))))
+
+;;; Starting the inferior Lisp and loading Swank:
+
+(defun slime-maybe-start-lisp (program program-args env directory buffer)
+ "Return a new or existing inferior lisp process."
+ (cond ((not (comint-check-proc buffer))
+ (slime-start-lisp program program-args env directory buffer))
+ ((slime-reinitialize-inferior-lisp-p program program-args env buffer)
+ (let ((conn (cl-find (get-buffer-process buffer)
+ slime-net-processes
+ :key #'slime-inferior-process)))
+ (when conn
+ (slime-net-close conn)))
+ (get-buffer-process buffer))
+ (t (slime-start-lisp program program-args env directory
+ (generate-new-buffer-name buffer)))))
+
+(defun slime-reinitialize-inferior-lisp-p (program program-args env buffer)
+ (let ((args (slime-inferior-lisp-args (get-buffer-process buffer))))
+ (and (equal (plist-get args :program) program)
+ (equal (plist-get args :program-args) program-args)
+ (equal (plist-get args :env) env)
+ (not (y-or-n-p "Create an additional *inferior-lisp*? ")))))
+
+(defvar slime-inferior-process-start-hook nil
+ "Hook called whenever a new process gets started.")
+
+(defun slime-start-lisp (program program-args env directory buffer)
+ "Does the same as `inferior-lisp' but less ugly.
+Return the created process."
+ (with-current-buffer (get-buffer-create buffer)
+ (when directory
+ (cd (expand-file-name directory)))
+ (comint-mode)
+ (let ((process-environment (append env process-environment))
+ (process-connection-type nil))
+ (comint-exec (current-buffer) "inferior-lisp" program nil program-args))
+ (lisp-mode-variables t)
+ (let ((proc (get-buffer-process (current-buffer))))
+ (slime-set-query-on-exit-flag proc)
+ (run-hooks 'slime-inferior-process-start-hook)
+ proc)))
+
+(defun slime-inferior-connect (process args)
+ "Start a Swank server in the inferior Lisp and connect."
+ (slime-delete-swank-port-file 'quiet)
+ (slime-start-swank-server process args)
+ (slime-read-port-and-connect process))
+
+(defvar slime-inferior-lisp-args nil
+ "A buffer local variable in the inferior proccess.
+See `slime-start'.")
+
+(defun slime-start-swank-server (process args)
+ "Start a Swank server on the inferior lisp."
+ (cl-destructuring-bind (&key coding-system init &allow-other-keys) args
+ (with-current-buffer (process-buffer process)
+ (make-local-variable 'slime-inferior-lisp-args)
+ (setq slime-inferior-lisp-args args)
+ (let ((str (funcall init (slime-swank-port-file) coding-system)))
+ (goto-char (process-mark process))
+ (insert-before-markers str)
+ (process-send-string process str)))))
+
+(defun slime-inferior-lisp-args (process)
+ "Return the initial process arguments.
+See `slime-start'."
+ (with-current-buffer (process-buffer process)
+ slime-inferior-lisp-args))
+
+;; XXX load-server & start-server used to be separated. maybe that was better.
+(defun slime-init-command (port-filename _coding-system)
+ "Return a string to initialize Lisp."
+ (let ((loader (if (file-name-absolute-p slime-backend)
+ slime-backend
+ (concat slime-path slime-backend))))
+ ;; Return a single form to avoid problems with buffered input.
+ (format "%S\n\n"
+ `(progn
+ (load ,(slime-to-lisp-filename (expand-file-name loader))
+ :verbose t)
+ (funcall (read-from-string "swank-loader:init"))
+ (funcall (read-from-string "swank:start-server")
+ ,(slime-to-lisp-filename port-filename))))))
+
+(defun slime-swank-port-file ()
+ "Filename where the SWANK server writes its TCP port number."
+ (expand-file-name (format "slime.%S" (emacs-pid)) (slime-temp-directory)))
+
+(defun slime-temp-directory ()
+ (cond ((fboundp 'temp-directory) (temp-directory))
+ ((boundp 'temporary-file-directory) temporary-file-directory)
+ (t "/tmp/")))
+
+(defun slime-delete-swank-port-file (&optional quiet)
+ (condition-case data
+ (delete-file (slime-swank-port-file))
+ (error
+ (cl-ecase quiet
+ ((nil) (signal (car data) (cdr data)))
+ (quiet)
+ (message (message "Unable to delete swank port file %S"
+ (slime-swank-port-file)))))))
+
+(defun slime-read-port-and-connect (inferior-process)
+ (slime-attempt-connection inferior-process nil 1))
+
+(defun slime-attempt-connection (process retries attempt)
+ ;; A small one-state machine to attempt a connection with
+ ;; timer-based retries.
+ (slime-cancel-connect-retry-timer)
+ (let ((file (slime-swank-port-file)))
+ (unless (active-minibuffer-window)
+ (message "Polling %S .. %d (Abort with `M-x slime-abort-connection'.)"
+ file attempt))
+ (cond ((and (file-exists-p file)
+ (> (nth 7 (file-attributes file)) 0)) ; file size
+ (let ((port (slime-read-swank-port))
+ (args (slime-inferior-lisp-args process)))
+ (slime-delete-swank-port-file 'message)
+ (let ((c (slime-connect slime-lisp-host port
+ (plist-get args :coding-system))))
+ (slime-set-inferior-process c process))))
+ ((and retries (zerop retries))
+ (message "Gave up connecting to Swank after %d attempts." attempt))
+ ((eq (process-status process) 'exit)
+ (message "Failed to connect to Swank: inferior process exited."))
+ (t
+ (when (and (file-exists-p file)
+ (zerop (nth 7 (file-attributes file))))
+ (message "(Zero length port file)")
+ ;; the file may be in the filesystem but not yet written
+ (unless retries (setq retries 3)))
+ (cl-assert (not slime-connect-retry-timer))
+ (setq slime-connect-retry-timer
+ (run-with-timer
+ 0.3 nil
+ #'slime-timer-call #'slime-attempt-connection
+ process (and retries (1- retries))
+ (1+ attempt)))))))
+
+(defun slime-timer-call (fun &rest args)
+ "Call function FUN with ARGS, reporting all errors.
+
+The default condition handler for timer functions (see
+`timer-event-handler') ignores errors."
+ (condition-case data
+ (apply fun args)
+ ((debug error)
+ (debug nil (list "Error in timer" fun args data)))))
+
+(defun slime-cancel-connect-retry-timer ()
+ (when slime-connect-retry-timer
+ (cancel-timer slime-connect-retry-timer)
+ (setq slime-connect-retry-timer nil)))
+
+(defun slime-read-swank-port ()
+ "Read the Swank server port number from the `slime-swank-port-file'."
+ (save-excursion
+ (with-temp-buffer
+ (insert-file-contents (slime-swank-port-file))
+ (goto-char (point-min))
+ (let ((port (read (current-buffer))))
+ (cl-assert (integerp port))
+ port))))
+
+(defun slime-toggle-debug-on-swank-error ()
+ (interactive)
+ (if (slime-eval `(swank:toggle-debug-on-swank-error))
+ (message "Debug on SWANK error enabled.")
+ (message "Debug on SWANK error disabled.")))
+
+;;; Words of encouragement
+
+(defun slime-user-first-name ()
+ (let ((name (if (string= (user-full-name) "")
+ (user-login-name)
+ (user-full-name))))
+ (string-match "^[^ ]*" name)
+ (capitalize (match-string 0 name))))
+
+(defvar slime-words-of-encouragement
+ `("Let the hacking commence!"
+ "Hacks and glory await!"
+ "Hack and be merry!"
+ "Your hacking starts... NOW!"
+ "May the source be with you!"
+ "Take this REPL, brother, and may it serve you well."
+ "Lemonodor-fame is but a hack away!"
+ ,(format "%s, this could be the start of a beautiful program."
+ (slime-user-first-name)))
+ "Scientifically-proven optimal words of hackerish encouragement.")
+
+(defun slime-random-words-of-encouragement ()
+ "Return a string of hackerish encouragement."
+ (eval (nth (random (length slime-words-of-encouragement))
+ slime-words-of-encouragement)))
+
+
+;;;; Networking
+;;;
+;;; This section covers the low-level networking: establishing
+;;; connections and encoding/decoding protocol messages.
+;;;
+;;; Each SLIME protocol message beings with a 6-byte header followed
+;;; by an S-expression as text. The sexp must be readable both by
+;;; Emacs and by Common Lisp, so if it contains any embedded code
+;;; fragments they should be sent as strings:
+;;;
+;;; The set of meaningful protocol messages are not specified
+;;; here. They are defined elsewhere by the event-dispatching
+;;; functions in this file and in swank.lisp.
+
+(defvar slime-net-processes nil
+ "List of processes (sockets) connected to Lisps.")
+
+(defvar slime-net-process-close-hooks '()
+ "List of functions called when a slime network connection closes.
+The functions are called with the process as their argument.")
+
+(defun slime-secret ()
+ "Find the magic secret from the user's home directory.
+Return nil if the file doesn't exist or is empty; otherwise the
+first line of the file."
+ (condition-case _err
+ (with-temp-buffer
+ (insert-file-contents "~/.slime-secret")
+ (goto-char (point-min))
+ (buffer-substring (point-min) (line-end-position)))
+ (file-error nil)))
+
+;;; Interface
+(defun slime-net-connect (host port)
+ "Establish a connection with a CL."
+ (let* ((inhibit-quit nil)
+ (proc (open-network-stream "SLIME Lisp" nil host port))
+ (buffer (slime-make-net-buffer " *cl-connection*")))
+ (push proc slime-net-processes)
+ (set-process-buffer proc buffer)
+ (set-process-filter proc 'slime-net-filter)
+ (set-process-sentinel proc 'slime-net-sentinel)
+ (slime-set-query-on-exit-flag proc)
+ (when (fboundp 'set-process-coding-system)
+ (set-process-coding-system proc 'binary 'binary))
+ (let ((secret (slime-secret)))
+ (when secret
+ (slime-net-send secret proc)))
+ proc))
+
+(defun slime-make-net-buffer (name)
+ "Make a buffer suitable for a network process."
+ (let ((buffer (generate-new-buffer name)))
+ (with-current-buffer buffer
+ (buffer-disable-undo)
+ (set (make-local-variable 'kill-buffer-query-functions) nil))
+ buffer))
+
+(defun slime-set-query-on-exit-flag (process)
+ "Set PROCESS's query-on-exit-flag to `slime-kill-without-query-p'."
+ (when slime-kill-without-query-p
+ ;; avoid byte-compiler warnings
+ (let ((fun (if (fboundp 'set-process-query-on-exit-flag)
+ 'set-process-query-on-exit-flag
+ 'process-kill-without-query)))
+ (funcall fun process nil))))
+
+;;;;; Coding system madness
+
+(defun slime-check-coding-system (coding-system)
+ "Signal an error if CODING-SYSTEM isn't a valid coding system."
+ (interactive)
+ (let ((props (slime-find-coding-system coding-system)))
+ (unless props
+ (error "Invalid slime-net-coding-system: %s. %s"
+ coding-system (mapcar #'car slime-net-valid-coding-systems)))
+ (when (and (cl-second props) (boundp 'default-enable-multibyte-characters))
+ (cl-assert default-enable-multibyte-characters))
+ t))
+
+(defun slime-coding-system-mulibyte-p (coding-system)
+ (cl-second (slime-find-coding-system coding-system)))
+
+(defun slime-coding-system-cl-name (coding-system)
+ (cl-third (slime-find-coding-system coding-system)))
+
+;;; Interface
+(defun slime-net-send (sexp proc)
+ "Send a SEXP to Lisp over the socket PROC.
+This is the lowest level of communication. The sexp will be READ and
+EVAL'd by Lisp."
+ (let* ((payload (encode-coding-string
+ (concat (slime-prin1-to-string sexp) "\n")
+ 'utf-8-unix))
+ (string (concat (slime-net-encode-length (length payload))
+ payload)))
+ (slime-log-event sexp)
+ (process-send-string proc string)))
+
+(defun slime-safe-encoding-p (coding-system string)
+ "Return true iff CODING-SYSTEM can safely encode STRING."
+ (or (let ((candidates (find-coding-systems-string string))
+ (base (coding-system-base coding-system)))
+ (or (equal candidates '(undecided))
+ (memq base candidates)))
+ (and (not (multibyte-string-p string))
+ (not (slime-coding-system-mulibyte-p coding-system)))))
+
+(defun slime-net-close (process &optional debug)
+ (setq slime-net-processes (remove process slime-net-processes))
+ (when (eq process slime-default-connection)
+ (setq slime-default-connection nil))
+ (cond (debug
+ (set-process-sentinel process 'ignore)
+ (set-process-filter process 'ignore)
+ (delete-process process))
+ (t
+ (run-hook-with-args 'slime-net-process-close-hooks process)
+ ;; killing the buffer also closes the socket
+ (kill-buffer (process-buffer process)))))
+
+(defun slime-net-sentinel (process message)
+ (message "Lisp connection closed unexpectedly: %s" message)
+ (slime-net-close process))
+
+;;; Socket input is handled by `slime-net-filter', which decodes any
+;;; complete messages and hands them off to the event dispatcher.
+
+(defun slime-net-filter (process string)
+ "Accept output from the socket and process all complete messages."
+ (with-current-buffer (process-buffer process)
+ (goto-char (point-max))
+ (insert string))
+ (slime-process-available-input process))
+
+(defun slime-process-available-input (process)
+ "Process all complete messages that have arrived from Lisp."
+ (with-current-buffer (process-buffer process)
+ (while (slime-net-have-input-p)
+ (let ((event (slime-net-read-or-lose process))
+ (ok nil))
+ (slime-log-event event)
+ (unwind-protect
+ (save-current-buffer
+ (slime-dispatch-event event process)
+ (setq ok t))
+ (unless ok
+ (slime-run-when-idle 'slime-process-available-input process)))))))
+
+(defun slime-net-have-input-p ()
+ "Return true if a complete message is available."
+ (goto-char (point-min))
+ (and (>= (buffer-size) 6)
+ (>= (- (buffer-size) 6) (slime-net-decode-length))))
+
+(defun slime-run-when-idle (function &rest args)
+ "Call FUNCTION as soon as Emacs is idle."
+ (apply #'run-at-time 0 nil function args))
+
+(defun slime-handle-net-read-error (error)
+ (let ((packet (buffer-string)))
+ (slime-with-popup-buffer ((slime-buffer-name :error))
+ (princ (format "%s\nin packet:\n%s" (error-message-string error) packet))
+ (goto-char (point-min)))
+ (cond ((y-or-n-p "Skip this packet? ")
+ `(:emacs-skipped-packet ,packet))
+ (t
+ (when (y-or-n-p "Enter debugger instead? ")
+ (debug 'error error))
+ (signal (car error) (cdr error))))))
+
+(defun slime-net-read-or-lose (process)
+ (condition-case error
+ (slime-net-read)
+ (error
+ (slime-net-close process t)
+ (error "net-read error: %S" error))))
+
+(defun slime-net-read ()
+ "Read a message from the network buffer."
+ (goto-char (point-min))
+ (let* ((length (slime-net-decode-length))
+ (start (+ (point) 6))
+ (end (+ start length)))
+ (cl-assert (cl-plusp length))
+ (prog1 (save-restriction
+ (narrow-to-region start end)
+ (condition-case error
+ (progn
+ (decode-coding-region start end 'utf-8-unix)
+ (setq end (point-max))
+ (read (current-buffer)))
+ (error
+ (slime-handle-net-read-error error))))
+ (delete-region (point-min) end))))
+
+(defun slime-net-decode-length ()
+ (string-to-number (buffer-substring-no-properties (point) (+ (point) 6))
+ 16))
+
+(defun slime-net-encode-length (n)
+ (format "%06x" n))
+
+(defun slime-prin1-to-string (sexp)
+ "Like `prin1-to-string' but don't octal-escape non-ascii characters.
+This is more compatible with the CL reader."
+ (let (print-escape-nonascii
+ print-escape-newlines
+ print-length
+ print-level)
+ (prin1-to-string sexp)))
+
+
+;;;; Connections
+;;;
+;;; "Connections" are the high-level Emacs<->Lisp networking concept.
+;;;
+;;; Emacs has a connection to each Lisp process that it's interacting
+;;; with. Typically there would only be one, but a user can choose to
+;;; connect to many Lisps simultaneously.
+;;;
+;;; A connection consists of a control socket, optionally an extra
+;;; socket dedicated to receiving Lisp output (an optimization), and a
+;;; set of connection-local state variables.
+;;;
+;;; The state variables are stored as buffer-local variables in the
+;;; control socket's process-buffer and are used via accessor
+;;; functions. These variables include things like the *FEATURES* list
+;;; and Unix Pid of the Lisp process.
+;;;
+;;; One connection is "current" at any given time. This is:
+;;; `slime-dispatching-connection' if dynamically bound, or
+;;; `slime-buffer-connection' if this is set buffer-local, or
+;;; `slime-default-connection' otherwise.
+;;;
+;;; When you're invoking commands in your source files you'll be using
+;;; `slime-default-connection'. This connection can be interactively
+;;; reassigned via the connection-list buffer.
+;;;
+;;; When a command creates a new buffer it will set
+;;; `slime-buffer-connection' so that commands in the new buffer will
+;;; use the connection that the buffer originated from. For example,
+;;; the apropos command creates the *Apropos* buffer and any command
+;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the
+;;; apropos search. REPL buffers are similarly tied to their
+;;; respective connections.
+;;;
+;;; When Emacs is dispatching some network message that arrived from a
+;;; connection it will dynamically bind `slime-dispatching-connection'
+;;; so that the event will be processed in the context of that
+;;; connection.
+;;;
+;;; This is mostly transparent. The user should be aware that he can
+;;; set the default connection to pick which Lisp handles commands in
+;;; Lisp-mode source buffers, and slime hackers should be aware that
+;;; they can tie a buffer to a specific connection. The rest takes
+;;; care of itself.
+
+(defvar slime-dispatching-connection nil
+ "Network process currently executing.
+This is dynamically bound while handling messages from Lisp; it
+overrides `slime-buffer-connection' and `slime-default-connection'.")
+
+(make-variable-buffer-local
+ (defvar slime-buffer-connection nil
+ "Network connection to use in the current buffer.
+This overrides `slime-default-connection'."))
+
+(defvar slime-default-connection nil
+ "Network connection to use by default.
+Used for all Lisp communication, except when overridden by
+`slime-dispatching-connection' or `slime-buffer-connection'.")
+
+(defun slime-current-connection ()
+ "Return the connection to use for Lisp interaction.
+Return nil if there's no connection."
+ (or slime-dispatching-connection
+ slime-buffer-connection
+ slime-default-connection))
+
+(defun slime-connection ()
+ "Return the connection to use for Lisp interaction.
+Signal an error if there's no connection."
+ (let ((conn (slime-current-connection)))
+ (cond ((and (not conn) slime-net-processes)
+ (or (slime-auto-select-connection)
+ (error "No default connection selected.")))
+ ((not conn)
+ (or (slime-auto-start)
+ (error "Not connected.")))
+ ((not (eq (process-status conn) 'open))
+ (error "Connection closed."))
+ (t conn))))
+
+(define-obsolete-variable-alias 'slime-auto-connect
+'slime-auto-start "2.5")
+(defcustom slime-auto-start 'never
+ "Controls auto connection when information from lisp process is needed.
+This doesn't mean it will connect right after Slime is loaded."
+ :group 'slime-mode
+ :type '(choice (const never)
+ (const always)
+ (const ask)))
+
+(defun slime-auto-start ()
+ (cond ((or (eq slime-auto-start 'always)
+ (and (eq slime-auto-start 'ask)
+ (y-or-n-p "No connection. Start Slime? ")))
+ (save-window-excursion
+ (slime)
+ (while (not (slime-current-connection))
+ (sleep-for 1))
+ (slime-connection)))
+ (t nil)))
+
+(defcustom slime-auto-select-connection 'ask
+ "Controls auto selection after the default connection was closed."
+ :group 'slime-mode
+ :type '(choice (const never)
+ (const always)
+ (const ask)))
+
+(defun slime-auto-select-connection ()
+ (let* ((c0 (car slime-net-processes))
+ (c (cond ((eq slime-auto-select-connection 'always) c0)
+ ((and (eq slime-auto-select-connection 'ask)
+ (y-or-n-p
+ (format "No default connection selected. %s %s? "
+ "Switch to" (slime-connection-name c0))))
+ c0))))
+ (when c
+ (slime-select-connection c)
+ (message "Switching to connection: %s" (slime-connection-name c))
+ c)))
+
+(defun slime-select-connection (process)
+ "Make PROCESS the default connection."
+ (setq slime-default-connection process))
+
+(defvar slime-cycle-connections-hook nil)
+
+(defun slime-cycle-connections-within (connections)
+ (let* ((tail (or (cdr (member (slime-current-connection) connections))
+ connections)) ; loop around to the beginning
+ (next (car tail)))
+ (slime-select-connection next)
+ (run-hooks 'slime-cycle-connections-hook)
+ (message "Lisp: %s %s"
+ (slime-connection-name next)
+ (process-contact next))))
+
+(defun slime-next-connection ()
+ "Change current slime connection, cycling through all connections."
+ (interactive)
+ (slime-cycle-connections-within (reverse slime-net-processes)))
+
+(define-obsolete-function-alias 'slime-cycle-connections
+ 'slime-next-connection "2.13")
+
+(defun slime-prev-connection ()
+ "Change current slime connection, cycling through all connections.
+Goes in reverse order, relative to `slime-next-connection'."
+ (interactive)
+ (slime-cycle-connections-within slime-net-processes))
+
+(cl-defmacro slime-with-connection-buffer ((&optional process) &rest body)
+ "Execute BODY in the process-buffer of PROCESS.
+If PROCESS is not specified, `slime-connection' is used.
+
+\(fn (&optional PROCESS) &body BODY))"
+ (declare (indent 1))
+ `(with-current-buffer
+ (process-buffer (or ,process (slime-connection)
+ (error "No connection")))
+ ,@body))
+
+;;; Connection-local variables:
+
+(defmacro slime-def-connection-var (varname &rest initial-value-and-doc)
+ "Define a connection-local variable.
+The value of the variable can be read by calling the function of the
+same name (it must not be accessed directly). The accessor function is
+setf-able.
+
+The actual variable bindings are stored buffer-local in the
+process-buffers of connections. The accessor function refers to
+the binding for `slime-connection'."
+ (declare (indent 2))
+ (let ((real-var (intern (format "%s:connlocal" varname))))
+ `(progn
+ ;; Variable
+ (make-variable-buffer-local
+ (defvar ,real-var ,@initial-value-and-doc))
+ ;; Accessor
+ (defun ,varname (&optional process)
+ (slime-with-connection-buffer (process) ,real-var))
+ ;; Setf
+ (defsetf ,varname (&optional process) (store)
+ `(slime-with-connection-buffer (,process)
+ (setq (\, (quote (\, real-var))) (\, store))))
+ '(\, varname))))
+
+(slime-def-connection-var slime-connection-number nil
+ "Serial number of a connection.
+Bound in the connection's process-buffer.")
+
+(slime-def-connection-var slime-lisp-features '()
+ "The symbol-names of Lisp's *FEATURES*.
+This is automatically synchronized from Lisp.")
+
+(slime-def-connection-var slime-lisp-modules '()
+ "The strings of Lisp's *MODULES*.")
+
+(slime-def-connection-var slime-pid nil
+ "The process id of the Lisp process.")
+
+(slime-def-connection-var slime-lisp-implementation-type nil
+ "The implementation type of the Lisp process.")
+
+(slime-def-connection-var slime-lisp-implementation-version nil
+ "The implementation type of the Lisp process.")
+
+(slime-def-connection-var slime-lisp-implementation-name nil
+ "The short name for the Lisp implementation.")
+
+(slime-def-connection-var slime-lisp-implementation-program nil
+ "The argv[0] of the process running the Lisp implementation.")
+
+(slime-def-connection-var slime-connection-name nil
+ "The short name for connection.")
+
+(slime-def-connection-var slime-inferior-process nil
+ "The inferior process for the connection if any.")
+
+(slime-def-connection-var slime-communication-style nil
+ "The communication style.")
+
+(slime-def-connection-var slime-machine-instance nil
+ "The name of the (remote) machine running the Lisp process.")
+
+(slime-def-connection-var slime-connection-coding-systems nil
+ "Coding systems supported by the Lisp process.")
+
+;;;;; Connection setup
+
+(defvar slime-connection-counter 0
+ "The number of SLIME connections made. For generating serial numbers.")
+
+;;; Interface
+(defun slime-setup-connection (process)
+ "Make a connection out of PROCESS."
+ (let ((slime-dispatching-connection process))
+ (slime-init-connection-state process)
+ (slime-select-connection process)
+ process))
+
+(defun slime-init-connection-state (proc)
+ "Initialize connection state in the process-buffer of PROC."
+ ;; To make life simpler for the user: if this is the only open
+ ;; connection then reset the connection counter.
+ (when (equal slime-net-processes (list proc))
+ (setq slime-connection-counter 0))
+ (slime-with-connection-buffer ()
+ (setq slime-buffer-connection proc))
+ (setf (slime-connection-number proc) (cl-incf slime-connection-counter))
+ ;; We do the rest of our initialization asynchronously. The current
+ ;; function may be called from a timer, and if we setup the REPL
+ ;; from a timer then it mysteriously uses the wrong keymap for the
+ ;; first command.
+ (let ((slime-current-thread t))
+ (slime-eval-async '(swank:connection-info)
+ (slime-curry #'slime-set-connection-info proc))))
+
+(defun slime-set-connection-info (connection info)
+ "Initialize CONNECTION with INFO received from Lisp."
+ (let ((slime-dispatching-connection connection)
+ (slime-current-thread t))
+ (cl-destructuring-bind (&key pid style lisp-implementation machine
+ features version modules encoding
+ &allow-other-keys) info
+ (slime-check-version version connection)
+ (setf (slime-pid) pid
+ (slime-communication-style) style
+ (slime-lisp-features) features
+ (slime-lisp-modules) modules)
+ (cl-destructuring-bind (&key type name version program)
+ lisp-implementation
+ (setf (slime-lisp-implementation-type) type
+ (slime-lisp-implementation-version) version
+ (slime-lisp-implementation-name) name
+ (slime-lisp-implementation-program) program
+ (slime-connection-name) (slime-generate-connection-name name)))
+ (cl-destructuring-bind (&key instance ((:type _)) ((:version _))) machine
+ (setf (slime-machine-instance) instance))
+ (cl-destructuring-bind (&key coding-systems) encoding
+ (setf (slime-connection-coding-systems) coding-systems)))
+ (let ((args (let ((p (slime-inferior-process)))
+ (if p (slime-inferior-lisp-args p)))))
+ (let ((name (plist-get args ':name)))
+ (when name
+ (unless (string= (slime-lisp-implementation-name) name)
+ (setf (slime-connection-name)
+ (slime-generate-connection-name (symbol-name name))))))
+ (slime-load-contribs)
+ (run-hooks 'slime-connected-hook)
+ (let ((fun (plist-get args ':init-function)))
+ (when fun (funcall fun))))
+ (message "Connected. %s" (slime-random-words-of-encouragement))))
+
+(defun slime-check-version (version conn)
+ (or (equal version slime-protocol-version)
+ (equal slime-protocol-version 'ignore)
+ (y-or-n-p
+ (format "Versions differ: %s (slime) vs. %s (swank). Continue? "
+ slime-protocol-version version))
+ (slime-net-close conn)
+ (top-level)))
+
+(defun slime-generate-connection-name (lisp-name)
+ (cl-loop for i from 1
+ for name = lisp-name then (format "%s<%d>" lisp-name i)
+ while (cl-find name slime-net-processes
+ :key #'slime-connection-name :test #'equal)
+ finally (cl-return name)))
+
+(defun slime-connection-close-hook (process)
+ (when (eq process slime-default-connection)
+ (when slime-net-processes
+ (slime-select-connection (car slime-net-processes))
+ (message "Default connection closed; switched to #%S (%S)"
+ (slime-connection-number)
+ (slime-connection-name)))))
+
+(add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook)
+
+;;;;; Commands on connections
+
+(defun slime-disconnect ()
+ "Close the current connection."
+ (interactive)
+ (slime-net-close (slime-connection)))
+
+(defun slime-disconnect-all ()
+ "Disconnect all connections."
+ (interactive)
+ (mapc #'slime-net-close slime-net-processes))
+
+(defun slime-connection-port (connection)
+ "Return the remote port number of CONNECTION."
+ (cadr (process-contact connection)))
+
+(defun slime-process (&optional connection)
+ "Return the Lisp process for CONNECTION (default `slime-connection').
+Return nil if there's no process object for the connection."
+ (let ((proc (slime-inferior-process connection)))
+ (if (and proc
+ (memq (process-status proc) '(run stop)))
+ proc)))
+
+;; Non-macro version to keep the file byte-compilable.
+(defun slime-set-inferior-process (connection process)
+ (setf (slime-inferior-process connection) process))
+
+(defun slime-use-sigint-for-interrupt (&optional connection)
+ (let ((c (or connection (slime-connection))))
+ (cl-ecase (slime-communication-style c)
+ ((:fd-handler nil) t)
+ ((:spawn :sigio) nil))))
+
+(defvar slime-inhibit-pipelining t
+ "*If true, don't send background requests if Lisp is already busy.")
+
+(defun slime-background-activities-enabled-p ()
+ (and (let ((con (slime-current-connection)))
+ (and con
+ (eq (process-status con) 'open)))
+ (or (not (slime-busy-p))
+ (not slime-inhibit-pipelining))))
+
+
+;;;; Communication protocol
+
+;;;;; Emacs Lisp programming interface
+;;;
+;;; The programming interface for writing Emacs commands is based on
+;;; remote procedure calls (RPCs). The basic operation is to ask Lisp
+;;; to apply a named Lisp function to some arguments, then to do
+;;; something with the result.
+;;;
+;;; Requests can be either synchronous (blocking) or asynchronous
+;;; (with the result passed to a callback/continuation function). If
+;;; an error occurs during the request then the debugger is entered
+;;; before the result arrives -- for synchronous evaluations this
+;;; requires a recursive edit.
+;;;
+;;; You should use asynchronous evaluations (`slime-eval-async') for
+;;; most things. Reserve synchronous evaluations (`slime-eval') for
+;;; the cases where blocking Emacs is really appropriate (like
+;;; completion) and that shouldn't trigger errors (e.g. not evaluate
+;;; user-entered code).
+;;;
+;;; We have the concept of the "current Lisp package". RPC requests
+;;; always say what package the user is making them from and the Lisp
+;;; side binds that package to *BUFFER-PACKAGE* to use as it sees
+;;; fit. The current package is defined as the buffer-local value of
+;;; `slime-buffer-package' if set, and otherwise the package named by
+;;; the nearest IN-PACKAGE as found by text search (cl-first backwards,
+;;; then forwards).
+;;;
+;;; Similarly we have the concept of the current thread, i.e. which
+;;; thread in the Lisp process should handle the request. The current
+;;; thread is determined solely by the buffer-local value of
+;;; `slime-current-thread'. This is usually bound to t meaning "no
+;;; particular thread", but can also be used to nominate a specific
+;;; thread. The REPL and the debugger both use this feature to deal
+;;; with specific threads.
+
+(make-variable-buffer-local
+ (defvar slime-current-thread t
+ "The id of the current thread on the Lisp side.
+t means the \"current\" thread;
+:repl-thread the thread that executes REPL requests;
+fixnum a specific thread."))
+
+(make-variable-buffer-local
+ (defvar slime-buffer-package nil
+ "The Lisp package associated with the current buffer.
+This is set only in buffers bound to specific packages."))
+
+;;; `slime-rex' is the RPC primitive which is used to implement both
+;;; `slime-eval' and `slime-eval-async'. You can use it directly if
+;;; you need to, but the others are usually more convenient.
+
+(cl-defmacro slime-rex ((&rest saved-vars)
+ (sexp &optional
+ (package '(slime-current-package))
+ (thread 'slime-current-thread))
+ &rest continuations)
+ "(slime-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...)
+
+Remote EXecute SEXP.
+
+VARs are a list of saved variables visible in the other forms. Each
+VAR is either a symbol or a list (VAR INIT-VALUE).
+
+SEXP is evaluated and the princed version is sent to Lisp.
+
+PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package.
+The default value is (slime-current-package).
+
+CLAUSES is a list of patterns with same syntax as
+`slime-dcase'. The result of the evaluation of SEXP is
+dispatched on CLAUSES. The result is either a sexp of the
+form (:ok VALUE) or (:abort CONDITION). CLAUSES is executed
+asynchronously.
+
+Note: don't use backquote syntax for SEXP, because various Emacs
+versions cannot deal with that."
+ (declare (indent 2))
+ (let ((result (cl-gensym)))
+ `(lexical-let ,(cl-loop for var in saved-vars
+ collect (cl-etypecase var
+ (symbol (list var var))
+ (cons var)))
+ (slime-dispatch-event
+ (list :emacs-rex ,sexp ,package ,thread
+ (lambda (,result)
+ (slime-dcase ,result
+ ,@continuations)))))))
+
+;;; Interface
+(defun slime-current-package ()
+ "Return the Common Lisp package in the current context.
+If `slime-buffer-package' has a value then return that, otherwise
+search for and read an `in-package' form."
+ (or slime-buffer-package
+ (save-restriction
+ (widen)
+ (slime-find-buffer-package))))
+
+(defvar slime-find-buffer-package-function 'slime-search-buffer-package
+ "*Function to use for `slime-find-buffer-package'.
+The result should be the package-name (a string)
+or nil if nothing suitable can be found.")
+
+(defun slime-find-buffer-package ()
+ "Figure out which Lisp package the current buffer is associated with."
+ (funcall slime-find-buffer-package-function))
+
+(make-variable-buffer-local
+ (defvar slime-package-cache nil
+ "Cons of the form (buffer-modified-tick . package)"))
+
+;; When modifing this code consider cases like:
+;; (in-package #.*foo*)
+;; (in-package #:cl)
+;; (in-package :cl)
+;; (in-package "CL")
+;; (in-package |CL|)
+;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp)
+
+(defun slime-search-buffer-package ()
+ (let ((case-fold-search t)
+ (regexp (concat "^(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*"
+ "\\([^)]+\\)[ \t]*)")))
+ (save-excursion
+ (when (or (re-search-backward regexp nil t)
+ (re-search-forward regexp nil t))
+ (match-string-no-properties 2)))))
+
+;;; Synchronous requests are implemented in terms of asynchronous
+;;; ones. We make an asynchronous request with a continuation function
+;;; that `throw's its result up to a `catch' and then enter a loop of
+;;; handling I/O until that happens.
+
+(defvar slime-stack-eval-tags nil
+ "List of stack-tags of continuations waiting on the stack.")
+
+(defun slime-eval (sexp &optional package)
+ "Evaluate EXPR on the superior Lisp and return the result."
+ (when (null package) (setq package (slime-current-package)))
+ (let* ((tag (cl-gensym (format "slime-result-%d-"
+ (1+ (slime-continuation-counter)))))
+ (slime-stack-eval-tags (cons tag slime-stack-eval-tags)))
+ (apply
+ #'funcall
+ (catch tag
+ (slime-rex (tag sexp)
+ (sexp package)
+ ((:ok value)
+ (unless (member tag slime-stack-eval-tags)
+ (error "Reply to canceled synchronous eval request tag=%S sexp=%S"
+ tag sexp))
+ (throw tag (list #'identity value)))
+ ((:abort _condition)
+ (throw tag (list #'error "Synchronous Lisp Evaluation aborted"))))
+ (let ((debug-on-quit t)
+ (inhibit-quit nil)
+ (conn (slime-connection)))
+ (while t
+ (unless (eq (process-status conn) 'open)
+ (error "Lisp connection closed unexpectedly"))
+ (accept-process-output nil 0.01)))))))
+
+(defun slime-eval-async (sexp &optional cont package)
+ "Evaluate EXPR on the superior Lisp and call CONT with the result."
+ (declare (indent 1))
+ (slime-rex (cont (buffer (current-buffer)))
+ (sexp (or package (slime-current-package)))
+ ((:ok result)
+ (when cont
+ (set-buffer buffer)
+ (funcall cont result)))
+ ((:abort condition)
+ (message "Evaluation aborted on %s." condition)))
+ ;; Guard against arbitrary return values which once upon a time
+ ;; showed up in the minibuffer spuriously (due to a bug in
+ ;; slime-autodoc.) If this ever happens again, returning the
+ ;; following will make debugging much easier:
+ :slime-eval-async)
+
+;;; These functions can be handy too:
+
+(defun slime-connected-p ()
+ "Return true if the Swank connection is open."
+ (not (null slime-net-processes)))
+
+(defun slime-check-connected ()
+ "Signal an error if we are not connected to Lisp."
+ (unless (slime-connected-p)
+ (error "Not connected. Use `%s' to start a Lisp."
+ (substitute-command-keys "\\[slime]"))))
+
+;; UNUSED
+(defun slime-debugged-connection-p (conn)
+ ;; This previously was (AND (SLDB-DEBUGGED-CONTINUATIONS CONN) T),
+ ;; but an SLDB buffer may exist without having continuations
+ ;; attached to it, e.g. the one resulting from `slime-interrupt'.
+ (cl-loop for b in (sldb-buffers)
+ thereis (with-current-buffer b
+ (eq slime-buffer-connection conn))))
+
+(defun slime-busy-p (&optional conn)
+ "True if Lisp has outstanding requests.
+Debugged requests are ignored."
+ (let ((debugged (sldb-debugged-continuations (or conn (slime-connection)))))
+ (cl-remove-if (lambda (id)
+ (memq id debugged))
+ (slime-rex-continuations)
+ :key #'car)))
+
+(defun slime-sync ()
+ "Block until the most recent request has finished."
+ (when (slime-rex-continuations)
+ (let ((tag (caar (slime-rex-continuations))))
+ (while (cl-find tag (slime-rex-continuations) :key #'car)
+ (accept-process-output nil 0.1)))))
+
+(defun slime-ping ()
+ "Check that communication works."
+ (interactive)
+ (message "%s" (slime-eval "PONG")))
+
+;;;;; Protocol event handler (cl-the guts)
+;;;
+;;; This is the protocol in all its glory. The input to this function
+;;; is a protocol event that either originates within Emacs or arrived
+;;; over the network from Lisp.
+;;;
+;;; Each event is a list beginning with a keyword and followed by
+;;; arguments. The keyword identifies the type of event. Events
+;;; originating from Emacs have names starting with :emacs- and events
+;;; from Lisp don't.
+
+(slime-def-connection-var slime-rex-continuations '()
+ "List of (ID . FUNCTION) continuations waiting for RPC results.")
+
+(slime-def-connection-var slime-continuation-counter 0
+ "Continuation serial number counter.")
+
+(defvar slime-event-hooks)
+
+(defun slime-dispatch-event (event &optional process)
+ (let ((slime-dispatching-connection (or process (slime-connection))))
+ (or (run-hook-with-args-until-success 'slime-event-hooks event)
+ (slime-dcase event
+ ((:emacs-rex form package thread continuation)
+ (when (and (slime-use-sigint-for-interrupt) (slime-busy-p))
+ (slime-display-oneliner "; pipelined request... %S" form))
+ (let ((id (cl-incf (slime-continuation-counter))))
+ (slime-send `(:emacs-rex ,form ,package ,thread ,id))
+ (push (cons id continuation) (slime-rex-continuations))
+ (slime--recompute-modelines)))
+ ((:return value id)
+ (let ((rec (assq id (slime-rex-continuations))))
+ (cond (rec (setf (slime-rex-continuations)
+ (remove rec (slime-rex-continuations)))
+ (slime--recompute-modelines)
+ (funcall (cdr rec) value))
+ (t
+ (error "Unexpected reply: %S %S" id value)))))
+ ((:debug-activate thread level &optional select)
+ (cl-assert thread)
+ (sldb-activate thread level select))
+ ((:debug thread level condition restarts frames conts)
+ (cl-assert thread)
+ (sldb-setup thread level condition restarts frames conts))
+ ((:debug-return thread level stepping)
+ (cl-assert thread)
+ (sldb-exit thread level stepping))
+ ((:emacs-interrupt thread)
+ (slime-send `(:emacs-interrupt ,thread)))
+ ((:channel-send id msg)
+ (slime-channel-send (or (slime-find-channel id)
+ (error "Invalid channel id: %S %S" id msg))
+ msg))
+ ((:emacs-channel-send id msg)
+ (slime-send `(:emacs-channel-send ,id ,msg)))
+ ((:read-from-minibuffer thread tag prompt initial-value)
+ (slime-read-from-minibuffer-for-swank thread tag prompt
+ initial-value))
+ ((:y-or-n-p thread tag question)
+ (slime-y-or-n-p thread tag question))
+ ((:emacs-return-string thread tag string)
+ (slime-send `(:emacs-return-string ,thread ,tag ,string)))
+ ((:new-features features)
+ (setf (slime-lisp-features) features))
+ ((:indentation-update info)
+ (slime-handle-indentation-update info))
+ ((:eval-no-wait form)
+ (slime-check-eval-in-emacs-enabled)
+ (eval (read form)))
+ ((:eval thread tag form-string)
+ (slime-check-eval-in-emacs-enabled)
+ (slime-eval-for-lisp thread tag form-string))
+ ((:emacs-return thread tag value)
+ (slime-send `(:emacs-return ,thread ,tag ,value)))
+ ((:ed what)
+ (slime-ed what))
+ ((:inspect what thread tag)
+ (let ((hook (when (and thread tag)
+ (slime-curry #'slime-send
+ `(:emacs-return ,thread ,tag nil)))))
+ (slime-open-inspector what nil hook)))
+ ((:background-message message)
+ (slime-background-message "%s" message))
+ ((:debug-condition thread message)
+ (cl-assert thread)
+ (message "%s" message))
+ ((:ping thread tag)
+ (slime-send `(:emacs-pong ,thread ,tag)))
+ ((:reader-error packet condition)
+ (slime-with-popup-buffer ((slime-buffer-name :error))
+ (princ (format "Invalid protocol message:\n%s\n\n%s"
+ condition packet))
+ (goto-char (point-min)))
+ (error "Invalid protocol message"))
+ ((:invalid-rpc id message)
+ (setf (slime-rex-continuations)
+ (cl-remove id (slime-rex-continuations) :key #'car))
+ (error "Invalid rpc: %s" message))
+ ((:emacs-skipped-packet _pkg))
+ ((:test-delay seconds) ; for testing only
+ (sit-for seconds))))))
+
+(defun slime-send (sexp)
+ "Send SEXP directly over the wire on the current connection."
+ (slime-net-send sexp (slime-connection)))
+
+(defun slime-reset ()
+ "Clear all pending continuations and erase connection buffer."
+ (interactive)
+ (setf (slime-rex-continuations) '())
+ (mapc #'kill-buffer (sldb-buffers))
+ (slime-with-connection-buffer ()
+ (erase-buffer)))
+
+(defun slime-send-sigint ()
+ (interactive)
+ (signal-process (slime-pid) 'SIGINT))
+
+;;;;; Channels
+
+;;; A channel implements a set of operations. Those operations can be
+;;; invoked by sending messages to the channel. Channels are used for
+;;; protocols which can't be expressed naturally with RPCs, e.g. for
+;;; streaming data over the wire.
+;;;
+;;; A channel can be "remote" or "local". Remote channels are
+;;; represented by integers. Local channels are structures. Messages
+;;; sent to a closed (remote) channel are ignored.
+
+(slime-def-connection-var slime-channels '()
+ "Alist of the form (ID . CHANNEL).")
+
+(slime-def-connection-var slime-channels-counter 0
+ "Channel serial number counter.")
+
+(cl-defstruct (slime-channel (:conc-name slime-channel.)
+ (:constructor
+ slime-make-channel% (operations name id plist)))
+ operations name id plist)
+
+(defun slime-make-channel (operations &optional name)
+ (let* ((id (cl-incf (slime-channels-counter)))
+ (ch (slime-make-channel% operations name id nil)))
+ (push (cons id ch) (slime-channels))
+ ch))
+
+(defun slime-close-channel (channel)
+ (setf (slime-channel.operations channel) 'closed-channel)
+ (let ((probe (assq (slime-channel.id channel) (slime-channels))))
+ (cond (probe (setf (slime-channels) (delete probe (slime-channels))))
+ (t (error "Invalid channel: %s" channel)))))
+
+(defun slime-find-channel (id)
+ (cdr (assq id (slime-channels))))
+
+(defun slime-channel-send (channel message)
+ (apply (or (gethash (car message) (slime-channel.operations channel))
+ (error "Unsupported operation: %S %S" message channel))
+ channel (cdr message)))
+
+(defun slime-channel-put (channel prop value)
+ (setf (slime-channel.plist channel)
+ (plist-put (slime-channel.plist channel) prop value)))
+
+(defun slime-channel-get (channel prop)
+ (plist-get (slime-channel.plist channel) prop))
+
+(eval-and-compile
+ (defun slime-channel-method-table-name (type)
+ (intern (format "slime-%s-channel-methods" type))))
+
+(defmacro slime-define-channel-type (name)
+ (declare (indent defun))
+ (let ((tab (slime-channel-method-table-name name)))
+ `(progn
+ (defvar ,tab)
+ (setq ,tab (make-hash-table :size 10)))))
+
+(defmacro slime-define-channel-method (type method args &rest body)
+ (declare (indent 3) (debug (&define name sexp lambda-list
+ def-body)))
+ `(puthash ',method
+ (lambda (self . ,args) . ,body)
+ ,(slime-channel-method-table-name type)))
+
+(defun slime-send-to-remote-channel (channel-id msg)
+ (slime-dispatch-event `(:emacs-channel-send ,channel-id ,msg)))
+
+;;;;; Event logging to *slime-events*
+;;;
+;;; The *slime-events* buffer logs all protocol messages for debugging
+;;; purposes. Optionally you can enable outline-mode in that buffer,
+;;; which is convenient but slows things down significantly.
+
+(defvar slime-log-events t
+ "*Log protocol events to the *slime-events* buffer.")
+
+(defvar slime-outline-mode-in-events-buffer nil
+ "*Non-nil means use outline-mode in *slime-events*.")
+
+(defvar slime-event-buffer-name (slime-buffer-name :events)
+ "The name of the slime event buffer.")
+
+(defun slime-log-event (event)
+ "Record the fact that EVENT occurred."
+ (when slime-log-events
+ (with-current-buffer (slime-events-buffer)
+ ;; trim?
+ (when (> (buffer-size) 100000)
+ (goto-char (/ (buffer-size) 2))
+ (re-search-forward "^(" nil t)
+ (delete-region (point-min) (point)))
+ (goto-char (point-max))
+ (save-excursion
+ (slime-pprint-event event (current-buffer)))
+ (when (and (boundp 'outline-minor-mode)
+ outline-minor-mode)
+ (hide-entry))
+ (goto-char (point-max)))))
+
+(defun slime-pprint-event (event buffer)
+ "Pretty print EVENT in BUFFER with limited depth and width."
+ (let ((print-length 20)
+ (print-level 6)
+ (pp-escape-newlines t))
+ (pp event buffer)))
+
+(defun slime-events-buffer ()
+ "Return or create the event log buffer."
+ (or (get-buffer slime-event-buffer-name)
+ (let ((buffer (get-buffer-create slime-event-buffer-name)))
+ (with-current-buffer buffer
+ (buffer-disable-undo)
+ (set (make-local-variable 'outline-regexp) "^(")
+ (set (make-local-variable 'comment-start) ";")
+ (set (make-local-variable 'comment-end) "")
+ (when slime-outline-mode-in-events-buffer
+ (outline-minor-mode)))
+ buffer)))
+
+
+;;;;; Cleanup after a quit
+
+(defun slime-restart-inferior-lisp ()
+ "Kill and restart the Lisp subprocess."
+ (interactive)
+ (cl-assert (slime-inferior-process) () "No inferior lisp process")
+ (slime-quit-lisp-internal (slime-connection) 'slime-restart-sentinel t))
+
+(defun slime-restart-sentinel (process _message)
+ "Restart the inferior lisp process.
+Also rearrange windows."
+ (cl-assert (process-status process) 'closed)
+ (let* ((proc (slime-inferior-process process))
+ (args (slime-inferior-lisp-args proc))
+ (buffer (buffer-name (process-buffer proc)))
+ ;;(buffer-window (get-buffer-window buffer))
+ (new-proc (slime-start-lisp (plist-get args :program)
+ (plist-get args :program-args)
+ (plist-get args :env)
+ nil
+ buffer)))
+ (slime-net-close process)
+ (slime-inferior-connect new-proc args)
+ (switch-to-buffer buffer)
+ (goto-char (point-max))))
+
+
+;;;; Compilation and the creation of compiler-note annotations
+
+(defvar slime-highlight-compiler-notes t
+ "*When non-nil annotate buffers with compilation notes etc.")
+
+(defvar slime-before-compile-functions nil
+ "A list of function called before compiling a buffer or region.
+The function receive two arguments: the beginning and the end of the
+region that will be compiled.")
+
+;; FIXME: remove some of the options
+(defcustom slime-compilation-finished-hook 'slime-maybe-show-compilation-log
+ "Hook called with a list of compiler notes after a compilation."
+ :group 'slime-mode
+ :type 'hook
+ :options '(slime-maybe-show-compilation-log
+ slime-create-compilation-log
+ slime-show-compilation-log
+ slime-maybe-list-compiler-notes
+ slime-list-compiler-notes
+ slime-maybe-show-xrefs-for-notes
+ slime-goto-first-note))
+
+;; FIXME: I doubt that anybody uses this directly and it seems to be
+;; only an ugly way to pass arguments.
+(defvar slime-compilation-policy nil
+ "When non-nil compile with these optimization settings.")
+
+(defun slime-compute-policy (arg)
+ "Return the policy for the prefix argument ARG."
+ (let ((between (lambda (min n max)
+ (cond ((< n min) min)
+ ((> n max) max)
+ (t n)))))
+ (let ((n (prefix-numeric-value arg)))
+ (cond ((not arg) slime-compilation-policy)
+ ((cl-plusp n) `((cl:debug . ,(funcall between 0 n 3))))
+ ((eq arg '-) `((cl:speed . 3)))
+ (t `((cl:speed . ,(funcall between 0 (abs n) 3))))))))
+
+(cl-defstruct (slime-compilation-result
+ (:type list)
+ (:conc-name slime-compilation-result.)
+ (:constructor nil)
+ (:copier nil))
+ tag notes successp duration loadp faslfile)
+
+(defvar slime-last-compilation-result nil
+ "The result of the most recently issued compilation.")
+
+(defun slime-compiler-notes ()
+ "Return all compiler notes, warnings, and errors."
+ (slime-compilation-result.notes slime-last-compilation-result))
+
+(defun slime-compile-and-load-file (&optional policy)
+ "Compile and load the buffer's file and highlight compiler notes.
+
+With (positive) prefix argument the file is compiled with maximal
+debug settings (`C-u'). With negative prefix argument it is compiled for
+speed (`M--'). If a numeric argument is passed set debug or speed settings
+to it depending on its sign.
+
+Each source location that is the subject of a compiler note is
+underlined and annotated with the relevant information. The commands
+`slime-next-note' and `slime-previous-note' can be used to navigate
+between compiler notes and to display their full details."
+ (interactive "P")
+ (slime-compile-file t (slime-compute-policy policy)))
+
+(defcustom slime-compile-file-options '()
+ "Plist of additional options that C-c C-k should pass to Lisp.
+Currently only :fasl-directory is supported."
+ :group 'slime-lisp
+ :type '(plist :key-type symbol :value-type (file :must-match t)))
+
+(defun slime-compile-file (&optional load policy)
+ "Compile current buffer's file and highlight resulting compiler notes.
+
+See `slime-compile-and-load-file' for further details."
+ (interactive)
+ (unless buffer-file-name
+ (error "Buffer %s is not associated with a file." (buffer-name)))
+ (check-parens)
+ (slime--maybe-save-buffer)
+ (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max))
+ (let ((file (slime-to-lisp-filename (buffer-file-name)))
+ (options (slime-simplify-plist `(,@slime-compile-file-options
+ :policy ,policy))))
+ (slime-eval-async
+ `(swank:compile-file-for-emacs ,file ,(if load t nil)
+ . ,(slime-hack-quotes options))
+ #'slime-compilation-finished)
+ (message "Compiling %s..." file)))
+
+;; FIXME: compilation-save-buffers-predicate was introduced in 24.1
+(defun slime--maybe-save-buffer ()
+ (let ((slime--this-buffer (current-buffer)))
+ (save-some-buffers (not compilation-ask-about-save)
+ (lambda () (eq (current-buffer) slime--this-buffer)))))
+
+(defun slime-hack-quotes (arglist)
+ ;; eval is the wrong primitive, we really want funcall
+ (cl-loop for arg in arglist collect `(quote ,arg)))
+
+(defun slime-simplify-plist (plist)
+ (cl-loop for (key val) on plist by #'cddr
+ append (cond ((null val) '())
+ (t (list key val)))))
+
+(defun slime-compile-defun (&optional raw-prefix-arg)
+ "Compile the current toplevel form.
+
+With (positive) prefix argument the form is compiled with maximal
+debug settings (`C-u'). With negative prefix argument it is compiled for
+speed (`M--'). If a numeric argument is passed set debug or speed settings
+to it depending on its sign."
+ (interactive "P")
+ (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg)))
+ (if (use-region-p)
+ (slime-compile-region (region-beginning) (region-end))
+ (apply #'slime-compile-region (slime-region-for-defun-at-point)))))
+
+(defun slime-compile-region (start end)
+ "Compile the region."
+ (interactive "r")
+ ;; Check connection before running hooks things like
+ ;; slime-flash-region don't make much sense if there's no connection
+ (slime-connection)
+ (slime-flash-region start end)
+ (run-hook-with-args 'slime-before-compile-functions start end)
+ (slime-compile-string (buffer-substring-no-properties start end) start))
+
+(defun slime-flash-region (start end &optional timeout)
+ "Temporarily highlight region from START to END."
+ (let ((overlay (make-overlay start end)))
+ (overlay-put overlay 'face 'secondary-selection)
+ (run-with-timer (or timeout 0.2) nil 'delete-overlay overlay)))
+
+(defun slime-compile-string (string start-offset)
+ (let* ((line (save-excursion
+ (goto-char start-offset)
+ (list (line-number-at-pos) (1+ (current-column)))))
+ (position `((:position ,start-offset) (:line ,@line))))
+ (slime-eval-async
+ `(swank:compile-string-for-emacs
+ ,string
+ ,(buffer-name)
+ ',position
+ ,(if (buffer-file-name) (slime-to-lisp-filename (buffer-file-name)))
+ ',slime-compilation-policy)
+ #'slime-compilation-finished)))
+
+(defcustom slime-load-failed-fasl 'ask
+ "Which action to take when COMPILE-FILE set FAILURE-P to T.
+NEVER doesn't load the fasl
+ALWAYS loads the fasl
+ASK asks the user."
+ :type '(choice (const never)
+ (const always)
+ (const ask)))
+
+(defun slime-load-failed-fasl-p ()
+ (cl-ecase slime-load-failed-fasl
+ (never nil)
+ (always t)
+ (ask (y-or-n-p "Compilation failed. Load fasl file anyway? "))))
+
+(defun slime-compilation-finished (result)
+ (with-struct (slime-compilation-result. notes duration successp
+ loadp faslfile) result
+ (setf slime-last-compilation-result result)
+ (slime-show-note-counts notes duration (cond ((not loadp) successp)
+ (t (and faslfile successp))))
+ (when slime-highlight-compiler-notes
+ (slime-highlight-notes notes))
+ (run-hook-with-args 'slime-compilation-finished-hook notes)
+ (when (and loadp faslfile
+ (or successp
+ (slime-load-failed-fasl-p)))
+ (slime-eval-async `(swank:load-file ,faslfile)))))
+
+(defun slime-show-note-counts (notes secs successp)
+ (message (concat
+ (cond (successp "Compilation finished")
+ (t (slime-add-face 'font-lock-warning-face
+ "Compilation failed")))
+ (if (null notes) ". (No warnings)" ": ")
+ (mapconcat
+ (lambda (messages)
+ (cl-destructuring-bind (sev . notes) messages
+ (let ((len (length notes)))
+ (format "%d %s%s" len (slime-severity-label sev)
+ (if (= len 1) "" "s")))))
+ (sort (slime-alistify notes #'slime-note.severity #'eq)
+ (lambda (x y) (slime-severity< (car y) (car x))))
+ " ")
+ (if secs (format " [%.2f secs]" secs)))))
+
+(defun slime-highlight-notes (notes)
+ "Highlight compiler notes, warnings, and errors in the buffer."
+ (interactive (list (slime-compiler-notes)))
+ (with-temp-message "Highlighting notes..."
+ (save-excursion
+ (save-restriction
+ (widen) ; highlight notes on the whole buffer
+ (slime-remove-old-overlays)
+ (mapc #'slime-overlay-note (slime-merge-notes-for-display notes))))))
+
+(defvar slime-note-overlays '()
+ "List of overlays created by `slime-make-note-overlay'")
+
+(defun slime-remove-old-overlays ()
+ "Delete the existing note overlays."
+ (mapc #'delete-overlay slime-note-overlays)
+ (setq slime-note-overlays '()))
+
+(defun slime-filter-buffers (predicate)
+ "Return a list of where PREDICATE returns true.
+PREDICATE is executed in the buffer to test."
+ (cl-remove-if-not (lambda (%buffer)
+ (with-current-buffer %buffer
+ (funcall predicate)))
+ (buffer-list)))
+
+;;;;; Recompilation.
+
+;; FIXME: This whole idea is questionable since it depends so
+;; crucially on precise source-locs.
+
+(defun slime-recompile-location (location)
+ (save-excursion
+ (slime-goto-source-location location)
+ (slime-compile-defun)))
+
+(defun slime-recompile-locations (locations cont)
+ (slime-eval-async
+ `(swank:compile-multiple-strings-for-emacs
+ ',(cl-loop for loc in locations collect
+ (save-excursion
+ (slime-goto-source-location loc)
+ (cl-destructuring-bind (start end)
+ (slime-region-for-defun-at-point)
+ (list (buffer-substring-no-properties start end)
+ (buffer-name)
+ (slime-current-package)
+ start
+ (if (buffer-file-name)
+ (slime-to-lisp-filename (buffer-file-name))
+ nil)))))
+ ',slime-compilation-policy)
+ cont))
+
+
+;;;;; Merging together compiler notes in the same location.
+
+(defun slime-merge-notes-for-display (notes)
+ "Merge together notes that refer to the same location.
+This operation is \"lossy\" in the broad sense but not for display purposes."
+ (mapcar #'slime-merge-notes
+ (slime-group-similar 'slime-notes-in-same-location-p notes)))
+
+(defun slime-merge-notes (notes)
+ "Merge NOTES together. Keep the highest severity, concatenate the messages."
+ (let* ((new-severity (cl-reduce #'slime-most-severe notes
+ :key #'slime-note.severity))
+ (new-message (mapconcat #'slime-note.message notes "\n")))
+ (let ((new-note (cl-copy-list (car notes))))
+ (setf (cl-getf new-note :message) new-message)
+ (setf (cl-getf new-note :severity) new-severity)
+ new-note)))
+
+(defun slime-notes-in-same-location-p (a b)
+ (equal (slime-note.location a) (slime-note.location b)))
+
+
+;;;;; Compiler notes list
+
+(defun slime-one-line-ify (string)
+ "Return a single-line version of STRING.
+Each newlines and following indentation is replaced by a single space."
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (while (re-search-forward "\n[\n \t]*" nil t)
+ (replace-match " "))
+ (buffer-string)))
+
+(defun slime-xrefs-for-notes (notes)
+ (let ((xrefs))
+ (dolist (note notes)
+ (let* ((location (cl-getf note :location))
+ (fn (cadr (assq :file (cdr location))))
+ (file (assoc fn xrefs))
+ (node
+ (list (format "%s: %s"
+ (cl-getf note :severity)
+ (slime-one-line-ify (cl-getf note :message)))
+ location)))
+ (when fn
+ (if file
+ (push node (cdr file))
+ (setf xrefs (cl-acons fn (list node) xrefs))))))
+ xrefs))
+
+(defun slime-maybe-show-xrefs-for-notes (notes)
+ "Show the compiler notes NOTES if they come from more than one file."
+ (let ((xrefs (slime-xrefs-for-notes notes)))
+ (when (slime-length> xrefs 1) ; >1 file
+ (slime-show-xrefs
+ xrefs 'definition "Compiler notes" (slime-current-package)))))
+
+(defun slime-note-has-location-p (note)
+ (not (eq ':error (car (slime-note.location note)))))
+
+(defun slime-redefinition-note-p (note)
+ (eq (slime-note.severity note) :redefinition))
+
+(defun slime-create-compilation-log (notes)
+ "Create a buffer for `next-error' to use."
+ (with-current-buffer (get-buffer-create (slime-buffer-name :compilation))
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (slime-insert-compilation-log notes)
+ (compilation-mode)))
+
+(defun slime-maybe-show-compilation-log (notes)
+ "Display the log on failed compilations or if NOTES is non-nil."
+ (slime-create-compilation-log notes)
+ (with-struct (slime-compilation-result. notes duration successp)
+ slime-last-compilation-result
+ (unless successp
+ (with-current-buffer (slime-buffer-name :compilation)
+ (let ((inhibit-read-only t))
+ (goto-char (point-max))
+ (insert "Compilation " (if successp "succeeded." "failed."))
+ (goto-char (point-min))
+ (display-buffer (current-buffer)))))))
+
+(defun slime-show-compilation-log (notes)
+ "Create and display the compilation log buffer."
+ (interactive (list (slime-compiler-notes)))
+ (slime-with-popup-buffer ((slime-buffer-name :compilation)
+ :mode 'compilation-mode)
+ (slime-insert-compilation-log notes)))
+
+(defun slime-insert-compilation-log (notes)
+ "Insert NOTES in format suitable for `compilation-mode'."
+ (cl-destructuring-bind (grouped-notes canonicalized-locs-table)
+ (slime-group-and-sort-notes notes)
+ (with-temp-message "Preparing compilation log..."
+ (let ((inhibit-read-only t)
+ (inhibit-modification-hooks t)) ; inefficient font-lock-hook
+ (insert (format "cd %s\n%d compiler notes:\n\n"
+ default-directory (length notes)))
+ (dolist (notes grouped-notes)
+ (let ((loc (gethash (cl-first notes) canonicalized-locs-table))
+ (start (point)))
+ (insert (slime-canonicalized-location-to-string loc) ":")
+ (slime-insert-note-group notes)
+ (insert "\n")
+ (slime-make-note-overlay (cl-first notes) start (1- (point))))))
+ (set (make-local-variable 'compilation-skip-threshold) 0)
+ (setq next-error-last-buffer (current-buffer)))))
+
+(defun slime-insert-note-group (notes)
+ "Insert a group of compiler messages."
+ (insert "\n")
+ (dolist (note notes)
+ (insert " " (slime-severity-label (slime-note.severity note)) ": ")
+ (let ((start (point)))
+ (insert (slime-note.message note))
+ (let ((ctx (slime-note.source-context note)))
+ (if ctx (insert "\n" ctx)))
+ (slime-indent-block start 4))
+ (insert "\n")))
+
+(defun slime-indent-block (start column)
+ "If the region back to START isn't a one-liner indent it."
+ (when (< start (line-beginning-position))
+ (save-excursion
+ (goto-char start)
+ (insert "\n"))
+ (slime-indent-rigidly start (point) column)))
+
+(defun slime-canonicalized-location (location)
+ "Return a list (FILE LINE COLUMN) for slime-location LOCATION.
+This is quite an expensive operation so use carefully."
+ (save-excursion
+ (slime-goto-location-buffer (slime-location.buffer location))
+ (save-excursion
+ (slime-goto-source-location location)
+ (list (or (buffer-file-name) (buffer-name))
+ (save-restriction
+ (widen)
+ (line-number-at-pos))
+ (1+ (current-column))))))
+
+(defun slime-canonicalized-location-to-string (loc)
+ (if loc
+ (cl-destructuring-bind (filename line col) loc
+ (format "%s:%d:%d"
+ (cond ((not filename) "")
+ ((let ((rel (file-relative-name filename)))
+ (if (< (length rel) (length filename))
+ rel)))
+ (t filename))
+ line col))
+ (format "Unknown location")))
+
+(defun slime-goto-note-in-compilation-log (note)
+ "Find `note' in the compilation log and display it."
+ (with-current-buffer (get-buffer (slime-buffer-name :compilation))
+ (let ((pos
+ (save-excursion
+ (goto-char (point-min))
+ (cl-loop for overlay = (slime-find-next-note)
+ while overlay
+ for other-note = (overlay-get overlay 'slime-note)
+ when (slime-notes-in-same-location-p note other-note)
+ return (overlay-start overlay)))))
+ (when pos
+ (slime--display-position pos nil 0)))))
+
+(defun slime-group-and-sort-notes (notes)
+ "First sort, then group NOTES according to their canonicalized locs."
+ (let ((locs (make-hash-table :test #'eq)))
+ (mapc (lambda (note)
+ (let ((loc (slime-note.location note)))
+ (when (slime-location-p loc)
+ (puthash note (slime-canonicalized-location loc) locs))))
+ notes)
+ (list (slime-group-similar
+ (lambda (n1 n2)
+ (equal (gethash n1 locs nil) (gethash n2 locs t)))
+ (let* ((bottom most-negative-fixnum)
+ (+default+ (list "" bottom bottom)))
+ (sort notes
+ (lambda (n1 n2)
+ (cl-destructuring-bind ((filename1 line1 col1)
+ (filename2 line2 col2))
+ (list (gethash n1 locs +default+)
+ (gethash n2 locs +default+))
+ (cond ((string-lessp filename1 filename2) t)
+ ((string-lessp filename2 filename1) nil)
+ ((< line1 line2) t)
+ ((> line1 line2) nil)
+ (t (< col1 col2))))))))
+ locs)))
+
+(defun slime-note.severity (note)
+ (plist-get note :severity))
+
+(defun slime-note.message (note)
+ (plist-get note :message))
+
+(defun slime-note.source-context (note)
+ (plist-get note :source-context))
+
+(defun slime-note.location (note)
+ (plist-get note :location))
+
+(defun slime-severity-label (severity)
+ (cl-subseq (symbol-name severity) 1))
+
+
+;;;;; Adding a single compiler note
+
+(defun slime-overlay-note (note)
+ "Add a compiler note to the buffer as an overlay.
+If an appropriate overlay for a compiler note in the same location
+already exists then the new information is merged into it. Otherwise a
+new overlay is created."
+ (cl-multiple-value-bind (start end) (slime-choose-overlay-region note)
+ (when start
+ (goto-char start)
+ (let ((severity (plist-get note :severity))
+ (message (plist-get note :message))
+ (overlay (slime-note-at-point)))
+ (if overlay
+ (slime-merge-note-into-overlay overlay severity message)
+ (slime-create-note-overlay note start end severity message))))))
+
+(defun slime-make-note-overlay (note start end)
+ (let ((overlay (make-overlay start end)))
+ (overlay-put overlay 'slime-note note)
+ (push overlay slime-note-overlays)
+ overlay))
+
+(defun slime-create-note-overlay (note start end severity message)
+ "Create an overlay representing a compiler note.
+The overlay has several properties:
+ FACE - to underline the relevant text.
+ SEVERITY - for future reference :NOTE, :STYLE-WARNING, :WARNING, or :ERROR.
+ MOUSE-FACE - highlight the note when the mouse passes over.
+ HELP-ECHO - a string describing the note, both for future reference
+ and for display as a tooltip (due to the special
+ property name)."
+ (let ((overlay (slime-make-note-overlay note start end)))
+ (cl-macrolet ((putp (name value) `(overlay-put overlay ,name ,value)))
+ (putp 'face (slime-severity-face severity))
+ (putp 'severity severity)
+ (putp 'mouse-face 'highlight)
+ (putp 'help-echo message)
+ overlay)))
+
+;; XXX Obsolete due to `slime-merge-notes-for-display' doing the
+;; work already -- unless we decide to put several sets of notes on a
+;; buffer without clearing in between, which only this handles.
+(defun slime-merge-note-into-overlay (overlay severity message)
+ "Merge another compiler note into an existing overlay.
+The help text describes both notes, and the highest of the severities
+is kept."
+ (cl-macrolet ((putp (name value) `(overlay-put overlay ,name ,value))
+ (getp (name) `(overlay-get overlay ,name)))
+ (putp 'severity (slime-most-severe severity (getp 'severity)))
+ (putp 'face (slime-severity-face (getp 'severity)))
+ (putp 'help-echo (concat (getp 'help-echo) "\n" message))))
+
+(defun slime-choose-overlay-region (note)
+ "Choose the start and end points for an overlay over NOTE.
+If the location's sexp is a list spanning multiple lines, then the
+region around the first element is used.
+Return nil if there's no useful source location."
+ (let ((location (slime-note.location note)))
+ (when location
+ (slime-dcase location
+ ((:error _)) ; do nothing
+ ((:location file pos _hints)
+ (cond ((eq (car file) ':source-form) nil)
+ ((eq (slime-note.severity note) :read-error)
+ (slime-choose-overlay-for-read-error location))
+ ((equal pos '(:eof))
+ (cl-values (1- (point-max)) (point-max)))
+ (t
+ (slime-choose-overlay-for-sexp location))))))))
+
+(defun slime-choose-overlay-for-read-error (location)
+ (let ((pos (slime-location-offset location)))
+ (save-excursion
+ (goto-char pos)
+ (cond ((slime-symbol-at-point)
+ ;; package not found, &c.
+ (cl-values (slime-symbol-start-pos) (slime-symbol-end-pos)))
+ (t
+ (cl-values pos (1+ pos)))))))
+
+(defun slime-choose-overlay-for-sexp (location)
+ (slime-goto-source-location location)
+ (skip-chars-forward "'#`")
+ (let ((start (point)))
+ (ignore-errors (slime-forward-sexp))
+ (if (slime-same-line-p start (point))
+ (cl-values start (point))
+ (cl-values (1+ start)
+ (progn (goto-char (1+ start))
+ (ignore-errors (forward-sexp 1))
+ (point))))))
+
+(defun slime-same-line-p (pos1 pos2)
+ "Return t if buffer positions POS1 and POS2 are on the same line."
+ (save-excursion (goto-char (min pos1 pos2))
+ (<= (max pos1 pos2) (line-end-position))))
+
+(defvar slime-severity-face-plist
+ '(:error slime-error-face
+ :read-error slime-error-face
+ :warning slime-warning-face
+ :redefinition slime-style-warning-face
+ :style-warning slime-style-warning-face
+ :note slime-note-face))
+
+(defun slime-severity-face (severity)
+ "Return the name of the font-lock face representing SEVERITY."
+ (or (plist-get slime-severity-face-plist severity)
+ (error "No face for: %S" severity)))
+
+(defvar slime-severity-order
+ '(:note :style-warning :redefinition :warning :error :read-error))
+
+(defun slime-severity< (sev1 sev2)
+ "Return true if SEV1 is less severe than SEV2."
+ (< (cl-position sev1 slime-severity-order)
+ (cl-position sev2 slime-severity-order)))
+
+(defun slime-most-severe (sev1 sev2)
+ "Return the most servere of two conditions."
+ (if (slime-severity< sev1 sev2) sev2 sev1))
+
+;; XXX: unused function
+(defun slime-visit-source-path (source-path)
+ "Visit a full source path including the top-level form."
+ (goto-char (point-min))
+ (slime-forward-source-path source-path))
+
+(defun slime-forward-positioned-source-path (source-path)
+ "Move forward through a sourcepath from a fixed position.
+The point is assumed to already be at the outermost sexp, making the
+first element of the source-path redundant."
+ (ignore-errors
+ (slime-forward-sexp)
+ (beginning-of-defun))
+ (let ((source-path (cdr source-path)))
+ (when source-path
+ (down-list 1)
+ (slime-forward-source-path source-path))))
+
+(defun slime-forward-source-path (source-path)
+ (let ((origin (point)))
+ (condition-case nil
+ (progn
+ (cl-loop for (count . more) on source-path
+ do (progn
+ (slime-forward-sexp count)
+ (when more (down-list 1))))
+ ;; Align at beginning
+ (slime-forward-sexp)
+ (beginning-of-sexp))
+ (error (goto-char origin)))))
+
+
+;; FIXME: really fix this mess
+;; FIXME: the check shouln't be done here anyway but by M-. itself.
+
+(defun slime-filesystem-toplevel-directory ()
+ ;; Windows doesn't have a true toplevel root directory, and all
+ ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs
+ ;; perspective anyway.
+ (if (memq system-type '(ms-dos windows-nt))
+ ""
+ (file-name-as-directory "/")))
+
+(defun slime-file-name-merge-source-root (target-filename buffer-filename)
+ "Returns a filename where the source root directory of TARGET-FILENAME
+is replaced with the source root directory of BUFFER-FILENAME.
+
+If no common source root could be determined, return NIL.
+
+E.g. (slime-file-name-merge-source-root
+ \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\"
+ \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\")
+
+ ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\"
+"
+ (let ((target-dirs (split-string (file-name-directory target-filename)
+ "/" t))
+ (buffer-dirs (split-string (file-name-directory buffer-filename)
+ "/" t)))
+ ;; Starting from the end, we look if one of the TARGET-DIRS exists
+ ;; in BUFFER-FILENAME---if so, it and everything left from that dirname
+ ;; is considered to be the source root directory of BUFFER-FILENAME.
+ (cl-loop with target-suffix-dirs = nil
+ with buffer-dirs* = (reverse buffer-dirs)
+ with target-dirs* = (reverse target-dirs)
+ for target-dir in target-dirs*
+ do (let ((concat-dirs (lambda (dirs)
+ (apply #'concat
+ (mapcar #'file-name-as-directory
+ dirs))))
+ (pos (cl-position target-dir buffer-dirs*
+ :test #'equal)))
+ (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME?
+ (push target-dir target-suffix-dirs)
+ (let* ((target-suffix
+ ; PUSH reversed for us!
+ (funcall concat-dirs target-suffix-dirs))
+ (buffer-root
+ (funcall concat-dirs
+ (reverse (nthcdr pos buffer-dirs*)))))
+ (cl-return (concat (slime-filesystem-toplevel-directory)
+ buffer-root
+ target-suffix
+ (file-name-nondirectory
+ target-filename)))))))))
+
+(defun slime-highlight-differences-in-dirname (base-dirname contrast-dirname)
+ "Returns a copy of BASE-DIRNAME where all differences between
+BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a
+highlighting face."
+ (setq base-dirname (file-name-as-directory base-dirname))
+ (setq contrast-dirname (file-name-as-directory contrast-dirname))
+ (let ((base-dirs (split-string base-dirname "/" t))
+ (contrast-dirs (split-string contrast-dirname "/" t)))
+ (with-temp-buffer
+ (cl-loop initially (insert (slime-filesystem-toplevel-directory))
+ for base-dir in base-dirs do
+ (let ((pos (cl-position base-dir contrast-dirs :test #'equal)))
+ (cond ((not pos)
+ (slime-insert-propertized '(face highlight) base-dir)
+ (insert "/"))
+ (t
+ (insert (file-name-as-directory base-dir))
+ (setq contrast-dirs
+ (nthcdr (1+ pos) contrast-dirs))))))
+ (buffer-substring (point-min) (point-max)))))
+
+(defvar slime-warn-when-possibly-tricked-by-M-. t
+ "When working on multiple source trees simultaneously, the way
+`slime-edit-definition' (M-.) works can sometimes be confusing:
+
+`M-.' visits locations that are present in the current Lisp image,
+which works perfectly well as long as the image reflects the source
+tree that one is currently looking at.
+
+In the other case, however, one can easily end up visiting a file
+in a different source root directory (cl-the one corresponding to
+the Lisp image), and is thus easily tricked to modify the wrong
+source files---which can lead to quite some stressfull cursing.
+
+If this variable is T, a warning message is issued to raise the
+user's attention whenever `M-.' is about opening a file in a
+different source root that also exists in the source root
+directory of the user's current buffer.
+
+There's no guarantee that all possible cases are covered, but
+if you encounter such a warning, it's a strong indication that
+you should check twice before modifying.")
+
+(defun slime-maybe-warn-for-different-source-root (target-filename
+ buffer-filename)
+ (let ((guessed-target (slime-file-name-merge-source-root target-filename
+ buffer-filename)))
+ (when (and guessed-target
+ (not (equal guessed-target target-filename))
+ (file-exists-p guessed-target))
+ (slime-message "Attention: This is `%s'."
+ (concat (slime-highlight-differences-in-dirname
+ (file-name-directory target-filename)
+ (file-name-directory guessed-target))
+ (file-name-nondirectory target-filename))))))
+
+(defun slime-check-location-filename-sanity (filename)
+ (when slime-warn-when-possibly-tricked-by-M-.
+ (cl-macrolet ((truename-safe (file) `(and ,file (file-truename ,file))))
+ (let ((target-filename (truename-safe filename))
+ (buffer-filename (truename-safe (buffer-file-name))))
+ (when (and target-filename
+ buffer-filename)
+ (slime-maybe-warn-for-different-source-root
+ target-filename buffer-filename))))))
+
+(defun slime-check-location-buffer-name-sanity (buffer-name)
+ (slime-check-location-filename-sanity
+ (buffer-file-name (get-buffer buffer-name))))
+
+
+
+(defun slime-goto-location-buffer (buffer)
+ (slime-dcase buffer
+ ((:file filename)
+ (let ((filename (slime-from-lisp-filename filename)))
+ (slime-check-location-filename-sanity filename)
+ (set-buffer (or (get-file-buffer filename)
+ (let ((find-file-suppress-same-file-warnings t))
+ (find-file-noselect filename))))))
+ ((:buffer buffer-name)
+ (slime-check-location-buffer-name-sanity buffer-name)
+ (set-buffer buffer-name))
+ ((:buffer-and-file buffer filename)
+ (slime-goto-location-buffer
+ (if (get-buffer buffer)
+ (list :buffer buffer)
+ (list :file filename))))
+ ((:source-form string)
+ (set-buffer (get-buffer-create (slime-buffer-name :source)))
+ (erase-buffer)
+ (lisp-mode)
+ (insert string)
+ (goto-char (point-min)))
+ ((:zip file entry)
+ (require 'arc-mode)
+ (set-buffer (find-file-noselect file t))
+ (goto-char (point-min))
+ (re-search-forward (concat " " entry "$"))
+ (let ((buffer (save-window-excursion
+ (archive-extract)
+ (current-buffer))))
+ (set-buffer buffer)
+ (goto-char (point-min))))))
+
+(defun slime-goto-location-position (position)
+ (slime-dcase position
+ ((:position pos)
+ (goto-char 1)
+ (forward-char (- (1- pos) (slime-eol-conversion-fixup (1- pos)))))
+ ((:offset start offset)
+ (goto-char start)
+ (forward-char offset))
+ ((:line start &optional column)
+ (goto-char (point-min))
+ (beginning-of-line start)
+ (cond (column (move-to-column column))
+ (t (skip-chars-forward " \t"))))
+ ((:function-name name)
+ (let ((case-fold-search t)
+ (name (regexp-quote name)))
+ (goto-char (point-min))
+ (when (or
+ (re-search-forward
+ (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_"
+ (regexp-quote name)) nil t)
+ (re-search-forward
+ (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t))
+ (goto-char (match-beginning 0)))))
+ ((:method name specializers &rest qualifiers)
+ (slime-search-method-location name specializers qualifiers))
+ ((:source-path source-path start-position)
+ (cond (start-position
+ (goto-char start-position)
+ (slime-forward-positioned-source-path source-path))
+ (t
+ (slime-forward-source-path source-path))))
+ ((:eof)
+ (goto-char (point-max)))))
+
+(defun slime-eol-conversion-fixup (n)
+ ;; Return the number of \r\n eol markers that we need to cross when
+ ;; moving N chars forward. N is the number of chars but \r\n are
+ ;; counted as 2 separate chars.
+ (cl-case (coding-system-eol-type buffer-file-coding-system)
+ ((1)
+ (save-excursion
+ (cl-do ((pos (+ (point) n))
+ (count 0 (1+ count)))
+ ((>= (point) pos) (1- count))
+ (forward-line)
+ (cl-decf pos))))
+ (t 0)))
+
+(defun slime-search-method-location (name specializers qualifiers)
+ ;; Look for a sequence of words (def<something> method name
+ ;; qualifers specializers don't look for "T" since it isn't requires
+ ;; (arg without t) as class is taken as such.
+ (let* ((case-fold-search t)
+ (name (regexp-quote name))
+ (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>"))
+ qualifiers ""))
+ (specializers (mapconcat
+ (lambda (el)
+ (if (eql (aref el 0) ?\()
+ (let ((spec (read el)))
+ (if (eq (car spec) 'EQL)
+ (concat
+ ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}"
+ (format "%s" (cl-second spec)) ")")
+ (error "don't understand specializer: %s,%s"
+ el (car spec))))
+ (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>")))
+ (remove "T" specializers) ""))
+ (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name
+ qualifiers specializers)))
+ (or (and (re-search-forward regexp nil t)
+ (goto-char (match-beginning 0)))
+ ;; (slime-goto-location-position `(:function-name ,name))
+ )))
+
+(defun slime-search-call-site (fname)
+ "Move to the place where FNAME called.
+Don't move if there are multiple or no calls in the current defun."
+ (save-restriction
+ (narrow-to-defun)
+ (let ((start (point))
+ (regexp (concat "(" fname "[)\n \t]"))
+ (case-fold-search t))
+ (cond ((and (re-search-forward regexp nil t)
+ (not (re-search-forward regexp nil t)))
+ (goto-char (match-beginning 0)))
+ (t (goto-char start))))))
+
+(defun slime-search-edit-path (edit-path)
+ "Move to EDIT-PATH starting at the current toplevel form."
+ (when edit-path
+ (unless (and (= (current-column) 0)
+ (looking-at "("))
+ (beginning-of-defun))
+ (slime-forward-source-path edit-path)))
+
+(defun slime-goto-source-location (location &optional noerror)
+ "Move to the source location LOCATION. Several kinds of locations
+are supported:
+
+<location> ::= (:location <buffer> <position> <hints>)
+ | (:error <message>)
+
+<buffer> ::= (:file <filename>)
+ | (:buffer <buffername>)
+ | (:buffer-and-file <buffername> <filename>)
+ | (:source-form <string>)
+ | (:zip <file> <entry>)
+
+<position> ::= (:position <fixnum>) ; 1 based (for files)
+ | (:offset <start> <offset>) ; start+offset (for C-c C-c)
+ | (:line <line> [<column>])
+ | (:function-name <string>)
+ | (:source-path <list> <start-position>)
+ | (:method <name string> <specializers> . <qualifiers>)"
+ (slime-dcase location
+ ((:location buffer _position _hints)
+ (slime-goto-location-buffer buffer)
+ (let ((pos (slime-location-offset location)))
+ (cond ((and (<= (point-min) pos) (<= pos (point-max))))
+ (widen-automatically (widen))
+ (t
+ (error "Location is outside accessible part of buffer")))
+ (goto-char pos)))
+ ((:error message)
+ (if noerror
+ (slime-message "%s" message)
+ (error "%s" message)))))
+
+(defun slime-location-offset (location)
+ "Return the position, as character number, of LOCATION."
+ (save-restriction
+ (widen)
+ (condition-case nil
+ (slime-goto-location-position
+ (slime-location.position location))
+ (error (goto-char 0)))
+ (cl-destructuring-bind (&key snippet edit-path call-site align)
+ (slime-location.hints location)
+ (when snippet (slime-isearch snippet))
+ (when edit-path (slime-search-edit-path edit-path))
+ (when call-site (slime-search-call-site call-site))
+ (when align
+ (slime-forward-sexp)
+ (beginning-of-sexp)))
+ (point)))
+
+
+;;;;; Incremental search
+;;
+;; Search for the longest match of a string in either direction.
+;;
+;; This is for locating text that is expected to be near the point and
+;; may have been modified (but hopefully not near the beginning!)
+
+(defun slime-isearch (string)
+ "Find the longest occurence of STRING either backwards of forwards.
+If multiple matches exist the choose the one nearest to point."
+ (goto-char
+ (let* ((start (point))
+ (len1 (slime-isearch-with-function 'search-forward string))
+ (pos1 (point)))
+ (goto-char start)
+ (let* ((len2 (slime-isearch-with-function 'search-backward string))
+ (pos2 (point)))
+ (cond ((and len1 len2)
+ ;; Have a match in both directions
+ (cond ((= len1 len2)
+ ;; Both are full matches -- choose the nearest.
+ (if (< (abs (- start pos1))
+ (abs (- start pos2)))
+ pos1 pos2))
+ ((> len1 len2) pos1)
+ ((> len2 len1) pos2)))
+ (len1 pos1)
+ (len2 pos2)
+ (t start))))))
+
+(defun slime-isearch-with-function (search-fn string)
+ "Search for the longest substring of STRING using SEARCH-FN.
+SEARCH-FN is either the symbol `search-forward' or `search-backward'."
+ (unless (string= string "")
+ (cl-loop for i from 1 to (length string)
+ while (funcall search-fn (substring string 0 i) nil t)
+ for match-data = (match-data)
+ do (cl-case search-fn
+ (search-forward (goto-char (match-beginning 0)))
+ (search-backward (goto-char (1+ (match-end 0)))))
+ finally (cl-return (if (null match-data)
+ nil
+ ;; Finish based on the last successful match
+ (store-match-data match-data)
+ (goto-char (match-beginning 0))
+ (- (match-end 0) (match-beginning 0)))))))
+
+
+;;;;; Visiting and navigating the overlays of compiler notes
+
+(defun slime-next-note ()
+ "Go to and describe the next compiler note in the buffer."
+ (interactive)
+ (let ((here (point))
+ (note (slime-find-next-note)))
+ (if note
+ (slime-show-note note)
+ (goto-char here)
+ (message "No next note."))))
+
+(defun slime-previous-note ()
+ "Go to and describe the previous compiler note in the buffer."
+ (interactive)
+ (let ((here (point))
+ (note (slime-find-previous-note)))
+ (if note
+ (slime-show-note note)
+ (goto-char here)
+ (message "No previous note."))))
+
+(defun slime-goto-first-note (&rest _)
+ "Go to the first note in the buffer."
+ (let ((point (point)))
+ (goto-char (point-min))
+ (cond ((slime-find-next-note)
+ (slime-show-note (slime-note-at-point)))
+ (t (goto-char point)))))
+
+(defun slime-remove-notes ()
+ "Remove compiler-note annotations from the current buffer."
+ (interactive)
+ (slime-remove-old-overlays))
+
+(defun slime-show-note (overlay)
+ "Present the details of a compiler note to the user."
+ (slime-temporarily-highlight-note overlay)
+ (if (get-buffer-window (slime-buffer-name :compilation) t)
+ (slime-goto-note-in-compilation-log (overlay-get overlay 'slime-note))
+ (let ((message (get-char-property (point) 'help-echo)))
+ (slime-message "%s" (if (zerop (length message)) "\"\"" message)))))
+
+;; FIXME: could probably use flash region
+(defun slime-temporarily-highlight-note (overlay)
+ "Temporarily highlight a compiler note's overlay.
+The highlighting is designed to both make the relevant source more
+visible, and to highlight any further notes that are nested inside the
+current one.
+
+The highlighting is automatically undone with a timer."
+ (run-with-timer 0.2 nil
+ #'overlay-put overlay 'face (overlay-get overlay 'face))
+ (overlay-put overlay 'face 'slime-highlight-face))
+
+
+;;;;; Overlay lookup operations
+
+(defun slime-note-at-point ()
+ "Return the overlay for a note starting at point, otherwise NIL."
+ (cl-find (point) (slime-note-overlays-at-point)
+ :key 'overlay-start))
+
+(defun slime-note-overlay-p (overlay)
+ "Return true if OVERLAY represents a compiler note."
+ (overlay-get overlay 'slime-note))
+
+(defun slime-note-overlays-at-point ()
+ "Return a list of all note overlays that are under the point."
+ (cl-remove-if-not 'slime-note-overlay-p (overlays-at (point))))
+
+(defun slime-find-next-note ()
+ "Go to the next position with the `slime-note' text property.
+Retuns the note overlay if such a position is found, otherwise nil."
+ (slime-search-property 'slime-note nil #'slime-note-at-point))
+
+(defun slime-find-previous-note ()
+ "Go to the next position with the `slime-note' text property.
+Retuns the note overlay if such a position is found, otherwise nil."
+ (slime-search-property 'slime-note t #'slime-note-at-point))
+
+
+;;;; Arglist Display
+
+(defun slime-space (n)
+ "Insert a space and print some relevant information (function arglist).
+Designed to be bound to the SPC key. Prefix argument can be used to insert
+more than one space."
+ (interactive "p")
+ (self-insert-command n)
+ (slime-echo-arglist))
+
+(put 'slime-space 'delete-selection t) ; for delete-section-mode & CUA
+
+(defun slime-echo-arglist ()
+ (when (slime-background-activities-enabled-p)
+ (let ((op (slime-operator-before-point)))
+ (when op
+ (slime-eval-async `(swank:operator-arglist ,op
+ ,(slime-current-package))
+ (lambda (arglist)
+ (when arglist
+ (slime-message "%s" arglist))))))))
+
+(defvar slime-operator-before-point-function 'slime-lisp-operator-before-point)
+
+(defun slime-operator-before-point ()
+ (funcall slime-operator-before-point-function))
+
+(defun slime-lisp-operator-before-point ()
+ (ignore-errors
+ (save-excursion
+ (backward-up-list 1)
+ (down-list 1)
+ (slime-symbol-at-point))))
+
+;;;; Completion
+
+;; FIXME: use this in Emacs 24
+;;(define-obsolete-function-alias slime-complete-symbol completion-at-point)
+
+(defalias 'slime-complete-symbol #'completion-at-point)
+(make-obsolete 'slime-complete-symbol #'completion-at-point "2015-10-17")
+
+;; This is the function that we add to
+;; `completion-at-point-functions'. For backward-compatibilty we look
+;; at `slime-complete-symbol-function' first. The indirection through
+;; `slime-completion-at-point-functions' is used so that users don't
+;; have to set `completion-at-point-functions' in every slime-like
+;; buffer.
+(defun slime--completion-at-point ()
+ (cond (slime-complete-symbol-function
+ slime-complete-symbol-function)
+ (t
+ (run-hook-with-args-until-success
+ 'slime-completion-at-point-functions))))
+
+(defun slime-setup-completion ()
+ (add-hook 'completion-at-point-functions #'slime--completion-at-point nil t))
+
+(defun slime-simple-completion-at-point ()
+ "Complete the symbol at point.
+Perform completion similar to `elisp-completion-at-point'."
+ (let* ((end (point))
+ (beg (slime-symbol-start-pos)))
+ (list beg end (completion-table-dynamic #'slime-simple-completions))))
+
+(defun slime-filename-completion ()
+ "If point is at a string starting with \", complete it as filename.
+Return nil if point is not at filename."
+ (when (save-excursion (re-search-backward "\"[^ \t\n]+\\="
+ (max (point-min) (- (point) 1000))
+ t))
+ (let ((comint-completion-addsuffix '("/" . "\"")))
+ (comint-filename-completion))))
+
+;; FIXME: for backward compatibility. Remove it one day
+;; together with slime-complete-symbol-function.
+(defun slime-simple-complete-symbol ()
+ (let ((completion-at-point-functions '(slime-maybe-complete-as-filename
+ slime-simple-completion-at-point)))
+ (completion-at-point)))
+
+;; NOTE: the original idea was to bind this to TAB but that no longer
+;; works as `completion-at-point' sets a transient keymap that
+;; overrides TAB. So this is rather useless now.
+(defun slime-indent-and-complete-symbol ()
+ "Indent the current line and perform symbol completion.
+First indent the line. If indenting doesn't move point, complete
+the symbol. If there's no symbol at the point, show the arglist
+for the most recently enclosed macro or function."
+ (interactive)
+ (let ((pos (point)))
+ (unless (get-text-property (line-beginning-position) 'slime-repl-prompt)
+ (lisp-indent-line))
+ (when (= pos (point))
+ (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t))
+ (completion-at-point))
+ ((memq (char-before) '(?\t ?\ ))
+ (slime-echo-arglist))))))
+
+(make-obsolete 'slime-indent-and-complete-symbol
+ "Set tab-always-indent to 'complete."
+ "2015-10-18")
+
+(defvar slime-minibuffer-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map "\t" #'completion-at-point)
+ (define-key map "\M-\t" #'completion-at-point)
+ map)
+ "Minibuffer keymap used for reading CL expressions.")
+
+(defvar slime-minibuffer-history '()
+ "History list of expressions read from the minibuffer.")
+
+(defun slime-minibuffer-setup-hook ()
+ (cons (lexical-let ((package (slime-current-package))
+ (connection (slime-connection)))
+ (lambda ()
+ (setq slime-buffer-package package)
+ (setq slime-buffer-connection connection)
+ (set-syntax-table lisp-mode-syntax-table)
+ (slime-setup-completion)))
+ minibuffer-setup-hook))
+
+(defun slime-read-from-minibuffer (prompt &optional initial-value history)
+ "Read a string from the minibuffer, prompting with PROMPT.
+If INITIAL-VALUE is non-nil, it is inserted into the minibuffer before
+reading input. The result is a string (\"\" if no input was given)."
+ (let ((minibuffer-setup-hook (slime-minibuffer-setup-hook)))
+ (read-from-minibuffer prompt initial-value slime-minibuffer-map
+ nil (or history 'slime-minibuffer-history))))
+
+(defun slime-bogus-completion-alist (list)
+ "Make an alist out of list.
+The same elements go in the CAR, and nil in the CDR. To support the
+apparently very stupid `try-completions' interface, that wants an
+alist but ignores CDRs."
+ (mapcar (lambda (x) (cons x nil)) list))
+
+(defun slime-simple-completions (prefix)
+ (cl-destructuring-bind (completions _partial)
+ (let ((slime-current-thread t))
+ (slime-eval
+ `(swank:simple-completions ,(substring-no-properties prefix)
+ ',(slime-current-package))))
+ completions))
+
+
+;;;; Edit definition
+
+(defun slime-push-definition-stack ()
+ "Add point to find-tag-marker-ring."
+ (require 'etags)
+ (ring-insert find-tag-marker-ring (point-marker)))
+
+(defun slime-pop-find-definition-stack ()
+ "Pop the edit-definition stack and goto the location."
+ (interactive)
+ (pop-tag-mark))
+
+(cl-defstruct (slime-xref (:conc-name slime-xref.) (:type list))
+ dspec location)
+
+(cl-defstruct (slime-location (:conc-name slime-location.) (:type list)
+ (:constructor nil)
+ (:copier nil))
+ tag buffer position hints)
+
+(defun slime-location-p (o) (and (consp o) (eq (car o) :location)))
+
+(defun slime-xref-has-location-p (xref)
+ (slime-location-p (slime-xref.location xref)))
+
+(defun make-slime-buffer-location (buffer-name position &optional hints)
+ `(:location (:buffer ,buffer-name) (:position ,position)
+ ,(when hints `(:hints ,hints))))
+
+(defun make-slime-file-location (file-name position &optional hints)
+ `(:location (:file ,file-name) (:position ,position)
+ ,(when hints `(:hints ,hints))))
+
+;;; The hooks are tried in order until one succeeds, otherwise the
+;;; default implementation involving `slime-find-definitions-function'
+;;; is used. The hooks are called with the same arguments as
+;;; `slime-edit-definition'.
+(defvar slime-edit-definition-hooks)
+
+(defun slime-edit-definition (&optional name where)
+ "Lookup the definition of the name at point.
+If there's no name at point, or a prefix argument is given, then the
+function name is prompted."
+ (interactive (list (or (and (not current-prefix-arg)
+ (slime-symbol-at-point))
+ (slime-read-symbol-name "Edit Definition of: "))))
+ ;; The hooks might search for a name in a different manner, so don't
+ ;; ask the user if it's missing before the hooks are run
+ (or (run-hook-with-args-until-success 'slime-edit-definition-hooks
+ name where)
+ (slime-edit-definition-cont (slime-find-definitions name)
+ name where)))
+
+(defun slime-edit-definition-cont (xrefs name where)
+ (cl-destructuring-bind (1loc file-alist) (slime-analyze-xrefs xrefs)
+ (cond ((null xrefs)
+ (error "No known definition for: %s (in %s)"
+ name (slime-current-package)))
+ (1loc
+ (slime-push-definition-stack)
+ (slime-pop-to-location (slime-xref.location (car xrefs)) where))
+ ((slime-length= xrefs 1) ; ((:error "..."))
+ (error "%s" (cadr (slime-xref.location (car xrefs)))))
+ (t
+ (slime-push-definition-stack)
+ (slime-show-xrefs file-alist 'definition name
+ (slime-current-package))))))
+
+(defvar slime-edit-uses-xrefs
+ '(:calls :macroexpands :binds :references :sets :specializes))
+
+;;; FIXME. TODO: Would be nice to group the symbols (in each
+;;; type-group) by their home-package.
+(defun slime-edit-uses (symbol)
+ "Lookup all the uses of SYMBOL."
+ (interactive (list (slime-read-symbol-name "Edit Uses of: ")))
+ (slime-xrefs slime-edit-uses-xrefs
+ symbol
+ (lambda (xrefs type symbol package)
+ (cond
+ ((null xrefs)
+ (message "No xref information found for %s." symbol))
+ ((and (slime-length= xrefs 1) ; one group
+ (slime-length= (cdar xrefs) 1)) ; one ref in group
+ (cl-destructuring-bind (_ (_ loc)) (cl-first xrefs)
+ (slime-push-definition-stack)
+ (slime-pop-to-location loc)))
+ (t
+ (slime-push-definition-stack)
+ (slime-show-xref-buffer xrefs type symbol package))))))
+
+(defun slime-analyze-xrefs (xrefs)
+ "Find common filenames in XREFS.
+Return a list (SINGLE-LOCATION FILE-ALIST).
+SINGLE-LOCATION is true if all xrefs point to the same location.
+FILE-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)."
+ (list (and xrefs
+ (let ((loc (slime-xref.location (car xrefs))))
+ (and (slime-location-p loc)
+ (cl-every (lambda (x) (equal (slime-xref.location x) loc))
+ (cdr xrefs)))))
+ (slime-alistify xrefs #'slime-xref-group #'equal)))
+
+(defun slime-xref-group (xref)
+ (cond ((slime-xref-has-location-p xref)
+ (slime-dcase (slime-location.buffer (slime-xref.location xref))
+ ((:file filename) filename)
+ ((:buffer bufname)
+ (let ((buffer (get-buffer bufname)))
+ (if buffer
+ (format "%S" buffer) ; "#<buffer foo.lisp>"
+ (format "%s (previously existing buffer)" bufname))))
+ ((:buffer-and-file _buffer filename) filename)
+ ((:source-form _) "(S-Exp)")
+ ((:zip _zip entry) entry)))
+ (t
+ "(No location)")))
+
+(defun slime-pop-to-location (location &optional where)
+ (slime-goto-source-location location)
+ (cl-ecase where
+ ((nil) (switch-to-buffer (current-buffer)))
+ (window (pop-to-buffer (current-buffer) t))
+ (frame (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t)))))
+
+(defun slime-postprocess-xref (original-xref)
+ "Process (for normalization purposes) an Xref comming directly
+from SWANK before the rest of Slime sees it. In particular,
+convert ETAGS based xrefs to actual file+position based
+locations."
+ (if (not (slime-xref-has-location-p original-xref))
+ (list original-xref)
+ (let ((loc (slime-xref.location original-xref)))
+ (slime-dcase (slime-location.buffer loc)
+ ((:etags-file tags-file)
+ (slime-dcase (slime-location.position loc)
+ ((:tag &rest tags)
+ (visit-tags-table tags-file)
+ (mapcar (lambda (xref)
+ (let ((old-dspec (slime-xref.dspec original-xref))
+ (new-dspec (slime-xref.dspec xref)))
+ (setf (slime-xref.dspec xref)
+ (format "%s: %s" old-dspec new-dspec))
+ xref))
+ (cl-mapcan #'slime-etags-definitions tags)))))
+ (t
+ (list original-xref))))))
+
+(defun slime-postprocess-xrefs (xrefs)
+ (cl-mapcan #'slime-postprocess-xref xrefs))
+
+(defun slime-find-definitions (name)
+ "Find definitions for NAME."
+ (slime-postprocess-xrefs (funcall slime-find-definitions-function name)))
+
+(defun slime-find-definitions-rpc (name)
+ (slime-eval `(swank:find-definitions-for-emacs ,name)))
+
+(defun slime-edit-definition-other-window (name)
+ "Like `slime-edit-definition' but switch to the other window."
+ (interactive (list (slime-read-symbol-name "Symbol: ")))
+ (slime-edit-definition name 'window))
+
+(defun slime-edit-definition-other-frame (name)
+ "Like `slime-edit-definition' but switch to the other window."
+ (interactive (list (slime-read-symbol-name "Symbol: ")))
+ (slime-edit-definition name 'frame))
+
+(defun slime-edit-definition-with-etags (name)
+ (interactive (list (slime-read-symbol-name "Symbol: ")))
+ (let ((xrefs (slime-etags-definitions name)))
+ (cond (xrefs
+ (message "Using tag file...")
+ (slime-edit-definition-cont xrefs name nil))
+ (t
+ (error "No known definition for: %s" name)))))
+
+(defun slime-etags-to-locations (name)
+ "Search for definitions matching `name' in the currently active
+tags table. Return a possibly empty list of slime-locations."
+ (let ((locs '()))
+ (save-excursion
+ (let ((first-time t))
+ (while (visit-tags-table-buffer (not first-time))
+ (setq first-time nil)
+ (goto-char (point-min))
+ (while (search-forward name nil t)
+ (beginning-of-line)
+ (cl-destructuring-bind (hint line &rest pos) (etags-snarf-tag)
+ (unless (eq hint t) ; hint==t if we are in a filename line
+ (push `(:location (:file ,(expand-file-name (file-of-tag)))
+ (:line ,line)
+ (:snippet ,hint))
+ locs))))))
+ (nreverse locs))))
+
+(defun slime-etags-definitions (name)
+ "Search definitions matching NAME in the tags file.
+The result is a (possibly empty) list of definitions."
+ (mapcar (lambda (loc)
+ (make-slime-xref :dspec (cl-second (slime-location.hints loc))
+ :location loc))
+ (slime-etags-to-locations name)))
+
+;;;;; first-change-hook
+
+(defun slime-first-change-hook ()
+ "Notify Lisp that a source file's buffer has been modified."
+ ;; Be careful not to disturb anything!
+ ;; In particular if we muck up the match-data then query-replace
+ ;; breaks. -luke (26/Jul/2004)
+ (save-excursion
+ (save-match-data
+ (when (and (buffer-file-name)
+ (file-exists-p (buffer-file-name))
+ (slime-background-activities-enabled-p))
+ (let ((filename (slime-to-lisp-filename (buffer-file-name))))
+ (slime-eval-async `(swank:buffer-first-change ,filename)))))))
+
+(defun slime-setup-first-change-hook ()
+ (add-hook (make-local-variable 'first-change-hook)
+ 'slime-first-change-hook))
+
+(add-hook 'slime-mode-hook 'slime-setup-first-change-hook)
+
+
+;;;; Eval for Lisp
+
+(defun slime-lisp-readable-p (x)
+ (or (stringp x)
+ (memq x '(nil t))
+ (integerp x)
+ (keywordp x)
+ (and (consp x)
+ (let ((l x))
+ (while (consp l)
+ (slime-lisp-readable-p (car x))
+ (setq l (cdr l)))
+ (slime-lisp-readable-p l)))))
+
+(defun slime-eval-for-lisp (thread tag form-string)
+ (let ((ok nil)
+ (value nil)
+ (error nil)
+ (c (slime-connection)))
+ (unwind-protect
+ (condition-case err
+ (progn
+ (slime-check-eval-in-emacs-enabled)
+ (setq value (eval (read form-string)))
+ (setq ok t))
+ ((debug error)
+ (setq error err)))
+ (let ((result (cond ((and ok
+ (not (slime-lisp-readable-p value)))
+ `(:unreadable ,(slime-prin1-to-string value)))
+ (ok `(:ok ,value))
+ (error `(:error ,(symbol-name (car error))
+ . ,(mapcar #'slime-prin1-to-string
+ (cdr error))))
+ (t `(:abort)))))
+ (slime-dispatch-event `(:emacs-return ,thread ,tag ,result) c)))))
+
+(defun slime-check-eval-in-emacs-enabled ()
+ "Raise an error if `slime-enable-evaluate-in-emacs' isn't true."
+ (unless slime-enable-evaluate-in-emacs
+ (error (concat "slime-eval-in-emacs disabled for security. "
+ "Set `slime-enable-evaluate-in-emacs' true to enable it."))))
+
+
+;;;; `ED'
+
+(defvar slime-ed-frame nil
+ "The frame used by `slime-ed'.")
+
+(defcustom slime-ed-use-dedicated-frame t
+ "*When non-nil, `slime-ed' will create and reuse a dedicated frame."
+ :type 'boolean
+ :group 'slime-mode)
+
+(defun slime-ed (what)
+ "Edit WHAT.
+
+WHAT can be:
+ A filename (string),
+ A list (:filename FILENAME &key LINE COLUMN POSITION),
+ A function name (:function-name STRING)
+ nil.
+
+This is for use in the implementation of COMMON-LISP:ED."
+ (when slime-ed-use-dedicated-frame
+ (unless (and slime-ed-frame (frame-live-p slime-ed-frame))
+ (setq slime-ed-frame (make-frame)))
+ (select-frame slime-ed-frame))
+ (when what
+ (slime-dcase what
+ ((:filename file &key line column position bytep)
+ (find-file (slime-from-lisp-filename file))
+ (when line (slime-goto-line line))
+ (when column (move-to-column column))
+ (when position
+ (goto-char (if bytep
+ (byte-to-position position)
+ position))))
+ ((:function-name name)
+ (slime-edit-definition name)))))
+
+(defun slime-goto-line (line-number)
+ "Move to line LINE-NUMBER (1-based).
+This is similar to `goto-line' but without pushing the mark and
+the display stuff that we neither need nor want."
+ (cl-assert (= (buffer-size) (- (point-max) (point-min))) ()
+ "slime-goto-line in narrowed buffer")
+ (goto-char (point-min))
+ (forward-line (1- line-number)))
+
+(defun slime-y-or-n-p (thread tag question)
+ (slime-dispatch-event `(:emacs-return ,thread ,tag ,(y-or-n-p question))))
+
+(defun slime-read-from-minibuffer-for-swank (thread tag prompt initial-value)
+ (let ((answer (condition-case nil
+ (slime-read-from-minibuffer prompt initial-value)
+ (quit nil))))
+ (slime-dispatch-event `(:emacs-return ,thread ,tag ,answer))))
+
+;;;; Interactive evaluation.
+
+(defun slime-interactive-eval (string)
+ "Read and evaluate STRING and print value in minibuffer.
+
+Note: If a prefix argument is in effect then the result will be
+inserted in the current buffer."
+ (interactive (list (slime-read-from-minibuffer "Slime Eval: ")))
+ (cl-case current-prefix-arg
+ ((nil)
+ (slime-eval-with-transcript `(swank:interactive-eval ,string)))
+ ((-)
+ (slime-eval-save string))
+ (t
+ (slime-eval-print string))))
+
+(defvar slime-transcript-start-hook nil
+ "Hook run before start an evalution.")
+(defvar slime-transcript-stop-hook nil
+ "Hook run after finishing a evalution.")
+
+(defun slime-display-eval-result (value)
+ (slime-message "%s" value))
+
+(defun slime-eval-with-transcript (form)
+ "Eval FORM in Lisp. Display output, if any."
+ (run-hooks 'slime-transcript-start-hook)
+ (slime-rex () (form)
+ ((:ok value)
+ (run-hooks 'slime-transcript-stop-hook)
+ (slime-display-eval-result value))
+ ((:abort condition)
+ (run-hooks 'slime-transcript-stop-hook)
+ (message "Evaluation aborted on %s." condition))))
+
+(defun slime-eval-print (string)
+ "Eval STRING in Lisp; insert any output and the result at point."
+ (slime-eval-async `(swank:eval-and-grab-output ,string)
+ (lambda (result)
+ (cl-destructuring-bind (output value) result
+ (push-mark)
+ (insert output value)))))
+
+(defun slime-eval-save (string)
+ "Evaluate STRING in Lisp and save the result in the kill ring."
+ (slime-eval-async `(swank:eval-and-grab-output ,string)
+ (lambda (result)
+ (cl-destructuring-bind (output value) result
+ (let ((string (concat output value)))
+ (kill-new string)
+ (message "Evaluation finished; pushed result to kill ring."))))))
+
+(defun slime-eval-describe (form)
+ "Evaluate FORM in Lisp and display the result in a new buffer."
+ (slime-eval-async form (slime-rcurry #'slime-show-description
+ (slime-current-package))))
+
+(defvar slime-description-autofocus nil
+ "If non-nil select description windows on display.")
+
+(defun slime-show-description (string package)
+ ;; So we can have one description buffer open per connection. Useful
+ ;; for comparing the output of DISASSEMBLE across implementations.
+ ;; FIXME: could easily be achieved with M-x rename-buffer
+ (let ((bufname (slime-buffer-name :description)))
+ (slime-with-popup-buffer (bufname :package package
+ :connection t
+ :select slime-description-autofocus)
+ (princ string)
+ (goto-char (point-min)))))
+
+(defun slime-last-expression ()
+ (buffer-substring-no-properties
+ (save-excursion (backward-sexp) (point))
+ (point)))
+
+(defun slime-eval-last-expression ()
+ "Evaluate the expression preceding point."
+ (interactive)
+ (slime-interactive-eval (slime-last-expression)))
+
+(defun slime-eval-defun ()
+ "Evaluate the current toplevel form.
+Use `slime-re-evaluate-defvar' if the from starts with '(defvar'"
+ (interactive)
+ (let ((form (slime-defun-at-point)))
+ (cond ((string-match "^(defvar " form)
+ (slime-re-evaluate-defvar form))
+ (t
+ (slime-interactive-eval form)))))
+
+(defun slime-eval-region (start end)
+ "Evaluate region."
+ (interactive "r")
+ (slime-eval-with-transcript
+ `(swank:interactive-eval-region
+ ,(buffer-substring-no-properties start end))))
+
+(defun slime-pprint-eval-region (start end)
+ "Evaluate region; pprint the value in a buffer."
+ (interactive "r")
+ (slime-eval-describe
+ `(swank:pprint-eval
+ ,(buffer-substring-no-properties start end))))
+
+(defun slime-eval-buffer ()
+ "Evaluate the current buffer.
+The value is printed in the echo area."
+ (interactive)
+ (slime-eval-region (point-min) (point-max)))
+
+(defun slime-re-evaluate-defvar (form)
+ "Force the re-evaluaton of the defvar form before point.
+
+First make the variable unbound, then evaluate the entire form."
+ (interactive (list (slime-last-expression)))
+ (slime-eval-with-transcript `(swank:re-evaluate-defvar ,form)))
+
+(defun slime-pprint-eval-last-expression ()
+ "Evaluate the form before point; pprint the value in a buffer."
+ (interactive)
+ (slime-eval-describe `(swank:pprint-eval ,(slime-last-expression))))
+
+(defun slime-eval-print-last-expression (string)
+ "Evaluate sexp before point; print value into the current buffer"
+ (interactive (list (slime-last-expression)))
+ (insert "\n")
+ (slime-eval-print string))
+
+;;;; Edit Lisp value
+;;;
+(defun slime-edit-value (form-string)
+ "\\<slime-edit-value-mode-map>\
+Edit the value of a setf'able form in a new buffer.
+The value is inserted into a temporary buffer for editing and then set
+in Lisp when committed with \\[slime-edit-value-commit]."
+ (interactive
+ (list (slime-read-from-minibuffer "Edit value (evaluated): "
+ (slime-sexp-at-point))))
+ (slime-eval-async `(swank:value-for-editing ,form-string)
+ (lexical-let ((form-string form-string)
+ (package (slime-current-package)))
+ (lambda (result)
+ (slime-edit-value-callback form-string result
+ package)))))
+
+(make-variable-buffer-local
+ (defvar slime-edit-form-string nil
+ "The form being edited by `slime-edit-value'."))
+
+(define-minor-mode slime-edit-value-mode
+ "Mode for editing a Lisp value."
+ nil
+ " Edit-Value"
+ '(("\C-c\C-c" . slime-edit-value-commit)))
+
+(defun slime-edit-value-callback (form-string current-value package)
+ (let* ((name (generate-new-buffer-name (format "*Edit %s*" form-string)))
+ (buffer (slime-with-popup-buffer (name :package package
+ :connection t
+ :select t
+ :mode 'lisp-mode)
+ (slime-popup-buffer-mode -1) ; don't want binding of 'q'
+ (slime-mode 1)
+ (slime-edit-value-mode 1)
+ (setq slime-edit-form-string form-string)
+ (insert current-value)
+ (current-buffer))))
+ (with-current-buffer buffer
+ (setq buffer-read-only nil)
+ (message "Type C-c C-c when done"))))
+
+(defun slime-edit-value-commit ()
+ "Commit the edited value to the Lisp image.
+\\(See `slime-edit-value'.)"
+ (interactive)
+ (if (null slime-edit-form-string)
+ (error "Not editing a value.")
+ (let ((value (buffer-substring-no-properties (point-min) (point-max))))
+ (lexical-let ((buffer (current-buffer)))
+ (slime-eval-async `(swank:commit-edited-value ,slime-edit-form-string
+ ,value)
+ (lambda (_)
+ (with-current-buffer buffer
+ (quit-window t))))))))
+
+;;;; Tracing
+
+(defun slime-untrace-all ()
+ "Untrace all functions."
+ (interactive)
+ (slime-eval `(swank:untrace-all)))
+
+(defun slime-toggle-trace-fdefinition (spec)
+ "Toggle trace."
+ (interactive (list (slime-read-from-minibuffer
+ "(Un)trace: " (slime-symbol-at-point))))
+ (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec))))
+
+
+
+(defun slime-disassemble-symbol (symbol-name)
+ "Display the disassembly for SYMBOL-NAME."
+ (interactive (list (slime-read-symbol-name "Disassemble: ")))
+ (slime-eval-describe `(swank:disassemble-form ,(concat "'" symbol-name))))
+
+(defun slime-undefine-function (symbol-name)
+ "Unbind the function slot of SYMBOL-NAME."
+ (interactive (list (slime-read-symbol-name "fmakunbound: " t)))
+ (slime-eval-async `(swank:undefine-function ,symbol-name)
+ (lambda (result) (message "%s" result))))
+
+(defun slime-unintern-symbol (symbol-name package)
+ "Unintern the symbol given with SYMBOL-NAME PACKAGE."
+ (interactive (list (slime-read-symbol-name "Unintern symbol: " t)
+ (slime-read-package-name "from package: "
+ (slime-current-package))))
+ (slime-eval-async `(swank:unintern-symbol ,symbol-name ,package)
+ (lambda (result) (message "%s" result))))
+
+(defun slime-delete-package (package-name)
+ "Delete the package with name PACKAGE-NAME."
+ (interactive (list (slime-read-package-name "Delete package: "
+ (slime-current-package))))
+ (slime-eval-async `(cl:delete-package
+ (swank::guess-package ,package-name))))
+
+(defun slime-load-file (filename)
+ "Load the Lisp file FILENAME."
+ (interactive (list
+ (read-file-name "Load file: " nil nil
+ nil (if (buffer-file-name)
+ (file-name-nondirectory
+ (buffer-file-name))))))
+ (let ((lisp-filename (slime-to-lisp-filename (expand-file-name filename))))
+ (slime-eval-with-transcript `(swank:load-file ,lisp-filename))))
+
+(defvar slime-change-directory-hooks nil
+ "Hook run by `slime-change-directory'.
+The functions are called with the new (absolute) directory.")
+
+(defun slime-change-directory (directory)
+ "Make DIRECTORY become Lisp's current directory.
+Return whatever swank:set-default-directory returns."
+ (let ((dir (expand-file-name directory)))
+ (prog1 (slime-eval `(swank:set-default-directory
+ ,(slime-to-lisp-filename dir)))
+ (slime-with-connection-buffer nil (cd-absolute dir))
+ (run-hook-with-args 'slime-change-directory-hooks dir))))
+
+(defun slime-cd (directory)
+ "Make DIRECTORY become Lisp's current directory.
+Return whatever swank:set-default-directory returns."
+ (interactive (list (read-directory-name "Directory: " nil nil t)))
+ (message "default-directory: %s" (slime-change-directory directory)))
+
+(defun slime-pwd ()
+ "Show Lisp's default directory."
+ (interactive)
+ (message "Directory %s" (slime-eval `(swank:default-directory))))
+
+
+;;;; Profiling
+
+(defun slime-toggle-profile-fdefinition (fname-string)
+ "Toggle profiling for FNAME-STRING."
+ (interactive (list (slime-read-from-minibuffer
+ "(Un)Profile: "
+ (slime-symbol-at-point))))
+ (slime-eval-async `(swank:toggle-profile-fdefinition ,fname-string)
+ (lambda (r) (message "%s" r))))
+
+(defun slime-unprofile-all ()
+ "Unprofile all functions."
+ (interactive)
+ (slime-eval-async '(swank:unprofile-all)
+ (lambda (r) (message "%s" r))))
+
+(defun slime-profile-report ()
+ "Print profile report."
+ (interactive)
+ (slime-eval-with-transcript '(swank:profile-report)))
+
+(defun slime-profile-reset ()
+ "Reset profile counters."
+ (interactive)
+ (slime-eval-async (slime-eval `(swank:profile-reset))
+ (lambda (r) (message "%s" r))))
+
+(defun slime-profiled-functions ()
+ "Return list of names of currently profiled functions."
+ (interactive)
+ (slime-eval-async `(swank:profiled-functions)
+ (lambda (r) (message "%s" r))))
+
+(defun slime-profile-package (package callers methods)
+ "Profile all functions in PACKAGE.
+If CALLER is non-nil names have counts of the most common calling
+functions recorded.
+If METHODS is non-nil, profile all methods of all generic function
+having names in the given package."
+ (interactive (list (slime-read-package-name "Package: ")
+ (y-or-n-p "Record the most common callers? ")
+ (y-or-n-p "Profile methods? ")))
+ (slime-eval-async `(swank:swank-profile-package ,package ,callers ,methods)
+ (lambda (r) (message "%s" r))))
+
+(defun slime-profile-by-substring (substring &optional package)
+ "Profile all functions which names contain SUBSTRING.
+If PACKAGE is NIL, then search in all packages."
+ (interactive (list
+ (slime-read-from-minibuffer
+ "Profile by matching substring: "
+ (slime-symbol-at-point))
+ (slime-read-package-name "Package (RET for all packages): ")))
+ (let ((package (unless (equal package "") package)))
+ (slime-eval-async `(swank:profile-by-substring ,substring ,package)
+ (lambda (r) (message "%s" r)) )))
+
+;;;; Documentation
+
+(defvar slime-documentation-lookup-function
+ 'slime-hyperspec-lookup)
+
+(defun slime-documentation-lookup ()
+ "Generalized documentation lookup. Defaults to hyperspec lookup."
+ (interactive)
+ (call-interactively slime-documentation-lookup-function))
+
+(defun slime-hyperspec-lookup (symbol-name)
+ "A wrapper for `hyperspec-lookup'"
+ (interactive (list (common-lisp-hyperspec-read-symbol-name
+ (slime-symbol-at-point))))
+ (hyperspec-lookup symbol-name))
+
+(defun slime-describe-symbol (symbol-name)
+ "Describe the symbol at point."
+ (interactive (list (slime-read-symbol-name "Describe symbol: ")))
+ (when (not symbol-name)
+ (error "No symbol given"))
+ (slime-eval-describe `(swank:describe-symbol ,symbol-name)))
+
+(defun slime-documentation (symbol-name)
+ "Display function- or symbol-documentation for SYMBOL-NAME."
+ (interactive (list (slime-read-symbol-name "Documentation for symbol: ")))
+ (when (not symbol-name)
+ (error "No symbol given"))
+ (slime-eval-describe
+ `(swank:documentation-symbol ,symbol-name)))
+
+(defun slime-describe-function (symbol-name)
+ (interactive (list (slime-read-symbol-name "Describe symbol's function: ")))
+ (when (not symbol-name)
+ (error "No symbol given"))
+ (slime-eval-describe `(swank:describe-function ,symbol-name)))
+
+(defface slime-apropos-symbol
+ '((t (:inherit bold)))
+ "Face for the symbol name in Apropos output."
+ :group 'slime)
+
+(defface slime-apropos-label
+ '((t (:inherit italic)))
+ "Face for label (`Function', `Variable' ...) in Apropos output."
+ :group 'slime)
+
+(defun slime-apropos-summary (string case-sensitive-p package only-external-p)
+ "Return a short description for the performed apropos search."
+ (concat (if case-sensitive-p "Case-sensitive " "")
+ "Apropos for "
+ (format "%S" string)
+ (if package (format " in package %S" package) "")
+ (if only-external-p " (external symbols only)" "")))
+
+(defun slime-apropos (string &optional only-external-p package
+ case-sensitive-p)
+ "Show all bound symbols whose names match STRING. With prefix
+arg, you're interactively asked for parameters of the search."
+ (interactive
+ (if current-prefix-arg
+ (list (read-string "SLIME Apropos: ")
+ (y-or-n-p "External symbols only? ")
+ (let ((pkg (slime-read-package-name "Package: ")))
+ (if (string= pkg "") nil pkg))
+ (y-or-n-p "Case-sensitive? "))
+ (list (read-string "SLIME Apropos: ") t nil nil)))
+ (let ((buffer-package (or package (slime-current-package))))
+ (slime-eval-async
+ `(swank:apropos-list-for-emacs ,string ,only-external-p
+ ,case-sensitive-p ',package)
+ (slime-rcurry #'slime-show-apropos string buffer-package
+ (slime-apropos-summary string case-sensitive-p
+ package only-external-p)))))
+
+(defun slime-apropos-all ()
+ "Shortcut for (slime-apropos <string> nil nil)"
+ (interactive)
+ (slime-apropos (read-string "SLIME Apropos: ") nil nil))
+
+(defun slime-apropos-package (package &optional internal)
+ "Show apropos listing for symbols in PACKAGE.
+With prefix argument include internal symbols."
+ (interactive (list (let ((pkg (slime-read-package-name "Package: ")))
+ (if (string= pkg "") (slime-current-package) pkg))
+ current-prefix-arg))
+ (slime-apropos "" (not internal) package))
+
+(autoload 'apropos-mode "apropos")
+(defun slime-show-apropos (plists string package summary)
+ (if (null plists)
+ (message "No apropos matches for %S" string)
+ (slime-with-popup-buffer ((slime-buffer-name :apropos)
+ :package package :connection t
+ :mode 'apropos-mode)
+ (if (boundp 'header-line-format)
+ (setq header-line-format summary)
+ (insert summary "\n\n"))
+ (slime-set-truncate-lines)
+ (slime-print-apropos plists)
+ (set-syntax-table lisp-mode-syntax-table)
+ (goto-char (point-min)))))
+
+(defvar slime-apropos-namespaces
+ '((:variable "Variable")
+ (:function "Function")
+ (:generic-function "Generic Function")
+ (:macro "Macro")
+ (:special-operator "Special Operator")
+ (:setf "Setf")
+ (:type "Type")
+ (:class "Class")
+ (:alien-type "Alien type")
+ (:alien-struct "Alien struct")
+ (:alien-union "Alien type")
+ (:alien-enum "Alien enum")))
+
+(defun slime-print-apropos (plists)
+ (dolist (plist plists)
+ (let ((designator (plist-get plist :designator)))
+ (cl-assert designator)
+ (slime-insert-propertized `(face slime-apropos-symbol) designator))
+ (terpri)
+ (cl-loop for (prop value) on plist by #'cddr
+ unless (eq prop :designator) do
+ (let ((namespace (cadr (or (assq prop slime-apropos-namespaces)
+ (error "Unknown property: %S" prop))))
+ (start (point)))
+ (princ " ")
+ (slime-insert-propertized `(face slime-apropos-label) namespace)
+ (princ ": ")
+ (princ (cl-etypecase value
+ (string value)
+ ((member nil :not-documented) "(not documented)")))
+ (add-text-properties
+ start (point)
+ (list 'type prop 'action 'slime-call-describer
+ 'button t 'apropos-label namespace
+ 'item (plist-get plist :designator)))
+ (terpri)))))
+
+(defun slime-call-describer (arg)
+ (let* ((pos (if (markerp arg) arg (point)))
+ (type (get-text-property pos 'type))
+ (item (get-text-property pos 'item)))
+ (slime-eval-describe `(swank:describe-definition-for-emacs ,item ,type))))
+
+(defun slime-info ()
+ "Open Slime manual"
+ (interactive)
+ (let ((file (expand-file-name "doc/slime.info" slime-path)))
+ (if (file-exists-p file)
+ (info file)
+ (message "No slime.info, run `make slime.info' in %s"
+ (expand-file-name "doc/" slime-path)))))
+
+
+;;;; XREF: cross-referencing
+
+(defvar slime-xref-mode-map)
+
+(define-derived-mode slime-xref-mode lisp-mode "Xref"
+ "slime-xref-mode: Major mode for cross-referencing.
+\\<slime-xref-mode-map>\
+The most important commands:
+\\[slime-xref-quit] - Dismiss buffer.
+\\[slime-show-xref] - Display referenced source and keep xref window.
+\\[slime-goto-xref] - Jump to referenced source and dismiss xref window.
+
+\\{slime-xref-mode-map}
+\\{slime-popup-buffer-mode-map}
+"
+ (slime-popup-buffer-mode)
+ (setq font-lock-defaults nil)
+ (setq delayed-mode-hooks nil)
+ (slime-mode -1))
+
+(slime-define-keys slime-xref-mode-map
+ ((kbd "RET") 'slime-goto-xref)
+ ((kbd "SPC") 'slime-goto-xref)
+ ("v" 'slime-show-xref)
+ ("n" 'slime-xref-next-line)
+ ("p" 'slime-xref-prev-line)
+ ("." 'slime-xref-next-line)
+ ("," 'slime-xref-prev-line)
+ ("\C-c\C-c" 'slime-recompile-xref)
+ ("\C-c\C-k" 'slime-recompile-all-xrefs)
+ ("\M-," 'slime-xref-retract)
+ ([remap next-line] 'slime-xref-next-line)
+ ([remap previous-line] 'slime-xref-prev-line)
+ )
+
+
+;;;;; XREF results buffer and window management
+
+(cl-defmacro slime-with-xref-buffer ((_xref-type _symbol &optional package)
+ &body body)
+ "Execute BODY in a xref buffer, then show that buffer."
+ (declare (indent 1))
+ `(slime-with-popup-buffer ((slime-buffer-name :xref)
+ :package ,package
+ :connection t
+ :select t
+ :mode 'slime-xref-mode)
+ (slime-set-truncate-lines)
+ ,@body))
+
+(defun slime-insert-xrefs (xref-alist)
+ "Insert XREF-ALIST in the current-buffer.
+XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...).
+GROUP and LABEL are for decoration purposes. LOCATION is a
+source-location."
+ (cl-loop for (group . refs) in xref-alist do
+ (slime-insert-propertized '(face bold) group "\n")
+ (cl-loop for (label location) in refs do
+ (slime-insert-propertized
+ (list 'slime-location location
+ 'face 'font-lock-keyword-face)
+ " " (slime-one-line-ify label) "\n")))
+ ;; Remove the final newline to prevent accidental window-scrolling
+ (backward-delete-char 1))
+
+(defun slime-xref-next-line ()
+ (interactive)
+ (slime-xref-show-location (slime-search-property 'slime-location)))
+
+(defun slime-xref-prev-line ()
+ (interactive)
+ (slime-xref-show-location (slime-search-property 'slime-location t)))
+
+(defun slime-xref-show-location (loc)
+ (cl-ecase (car loc)
+ (:location (slime-show-source-location loc nil 1))
+ (:error (message "%s" (cadr loc)))
+ ((nil))))
+
+(defvar slime-next-location-function nil
+ "Function to call for going to the next location.")
+
+(defvar slime-previous-location-function nil
+ "Function to call for going to the previous location.")
+
+(defvar slime-xref-last-buffer nil
+ "The most recent XREF results buffer.
+This is used by `slime-goto-next-xref'")
+
+(defun slime-show-xref-buffer (xrefs _type _symbol package)
+ (slime-with-xref-buffer (_type _symbol package)
+ (slime-insert-xrefs xrefs)
+ (setq slime-next-location-function 'slime-goto-next-xref)
+ (setq slime-previous-location-function 'slime-goto-previous-xref)
+ (setq slime-xref-last-buffer (current-buffer))
+ (goto-char (point-min))))
+
+(defun slime-show-xrefs (xrefs type symbol package)
+ "Show the results of an XREF query."
+ (if (null xrefs)
+ (message "No references found for %s." symbol)
+ (slime-show-xref-buffer xrefs type symbol package)))
+
+
+;;;;; XREF commands
+
+(defun slime-who-calls (symbol)
+ "Show all known callers of the function SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who calls: " t)))
+ (slime-xref :calls symbol))
+
+(defun slime-calls-who (symbol)
+ "Show all known functions called by the function SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who calls: " t)))
+ (slime-xref :calls-who symbol))
+
+(defun slime-who-references (symbol)
+ "Show all known referrers of the global variable SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who references: " t)))
+ (slime-xref :references symbol))
+
+(defun slime-who-binds (symbol)
+ "Show all known binders of the global variable SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who binds: " t)))
+ (slime-xref :binds symbol))
+
+(defun slime-who-sets (symbol)
+ "Show all known setters of the global variable SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who sets: " t)))
+ (slime-xref :sets symbol))
+
+(defun slime-who-macroexpands (symbol)
+ "Show all known expanders of the macro SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who macroexpands: " t)))
+ (slime-xref :macroexpands symbol))
+
+(defun slime-who-specializes (symbol)
+ "Show all known methods specialized on class SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who specializes: " t)))
+ (slime-xref :specializes symbol))
+
+(defun slime-list-callers (symbol-name)
+ "List the callers of SYMBOL-NAME in a xref window."
+ (interactive (list (slime-read-symbol-name "List callers: ")))
+ (slime-xref :callers symbol-name))
+
+(defun slime-list-callees (symbol-name)
+ "List the callees of SYMBOL-NAME in a xref window."
+ (interactive (list (slime-read-symbol-name "List callees: ")))
+ (slime-xref :callees symbol-name))
+
+;; FIXME: whats the call (slime-postprocess-xrefs result) good for?
+(defun slime-xref (type symbol &optional continuation)
+ "Make an XREF request to Lisp."
+ (slime-eval-async
+ `(swank:xref ',type ',symbol)
+ (slime-rcurry (lambda (result type symbol package cont)
+ (slime-check-xref-implemented type result)
+ (let* ((_xrefs (slime-postprocess-xrefs result))
+ (file-alist (cadr (slime-analyze-xrefs result))))
+ (funcall (or cont 'slime-show-xrefs)
+ file-alist type symbol package)))
+ type
+ symbol
+ (slime-current-package)
+ continuation)))
+
+(defun slime-check-xref-implemented (type xrefs)
+ (when (eq xrefs :not-implemented)
+ (error "%s is not implemented yet on %s."
+ (slime-xref-type type)
+ (slime-lisp-implementation-name))))
+
+(defun slime-xref-type (type)
+ (format "who-%s" (slime-cl-symbol-name type)))
+
+(defun slime-xrefs (types symbol &optional continuation)
+ "Make multiple XREF requests at once."
+ (slime-eval-async
+ `(swank:xrefs ',types ',symbol)
+ #'(lambda (result)
+ (funcall (or continuation
+ #'slime-show-xrefs)
+ (cl-loop for (key . val) in result
+ collect (cons (slime-xref-type key) val))
+ types symbol (slime-current-package)))))
+
+
+;;;;; XREF navigation
+
+(defun slime-xref-location-at-point ()
+ (save-excursion
+ ;; When the end of the last line is at (point-max) we can't find
+ ;; the text property there. Going to bol avoids this problem.
+ (beginning-of-line 1)
+ (or (get-text-property (point) 'slime-location)
+ (error "No reference at point."))))
+
+(defun slime-xref-dspec-at-point ()
+ (save-excursion
+ (beginning-of-line 1)
+ (with-syntax-table lisp-mode-syntax-table
+ (forward-sexp) ; skip initial whitespaces
+ (backward-sexp)
+ (slime-sexp-at-point))))
+
+(defun slime-all-xrefs ()
+ (let ((xrefs nil))
+ (save-excursion
+ (goto-char (point-min))
+ (while (zerop (forward-line 1))
+ (let ((loc (get-text-property (point) 'slime-location)))
+ (when loc
+ (let* ((dspec (slime-xref-dspec-at-point))
+ (xref (make-slime-xref :dspec dspec :location loc)))
+ (push xref xrefs))))))
+ (nreverse xrefs)))
+
+(defun slime-goto-xref ()
+ "Goto the cross-referenced location at point."
+ (interactive)
+ (slime-show-xref)
+ (quit-window))
+
+(defun slime-show-xref ()
+ "Display the xref at point in the other window."
+ (interactive)
+ (let ((location (slime-xref-location-at-point)))
+ (slime-show-source-location location t 1)))
+
+(defun slime-goto-next-xref (&optional backward)
+ "Goto the next cross-reference location."
+ (if (not (buffer-live-p slime-xref-last-buffer))
+ (error "No XREF buffer alive.")
+ (cl-destructuring-bind (location pos)
+ (with-current-buffer slime-xref-last-buffer
+ (list (slime-search-property 'slime-location backward)
+ (point)))
+ (cond ((slime-location-p location)
+ (slime-pop-to-location location)
+ ;; We do this here because changing the location can take
+ ;; a while when Emacs needs to read a file from disk.
+ (with-current-buffer slime-xref-last-buffer
+ (goto-char pos)
+ (slime-highlight-line 0.35)))
+ ((null location)
+ (message (if backward "No previous xref" "No next xref.")))
+ (t ; error location
+ (slime-goto-next-xref backward))))))
+
+(defun slime-goto-previous-xref ()
+ "Goto the previous cross-reference location."
+ (slime-goto-next-xref t))
+
+(defun slime-search-property (prop &optional backward prop-value-fn)
+ "Search the next text range where PROP is non-nil.
+Return the value of PROP.
+If BACKWARD is non-nil, search backward.
+If PROP-VALUE-FN is non-nil use it to extract PROP's value."
+ (let ((next-candidate (if backward
+ #'previous-single-char-property-change
+ #'next-single-char-property-change))
+ (prop-value-fn (or prop-value-fn
+ (lambda ()
+ (get-text-property (point) prop))))
+ (start (point))
+ (prop-value))
+ (while (progn
+ (goto-char (funcall next-candidate (point) prop))
+ (not (or (setq prop-value (funcall prop-value-fn))
+ (eobp)
+ (bobp)))))
+ (cond (prop-value)
+ (t (goto-char start) nil))))
+
+(defun slime-next-location ()
+ "Go to the next location, depending on context.
+When displaying XREF information, this goes to the next reference."
+ (interactive)
+ (when (null slime-next-location-function)
+ (error "No context for finding locations."))
+ (funcall slime-next-location-function))
+
+(defun slime-previous-location ()
+ "Go to the previous location, depending on context.
+When displaying XREF information, this goes to the previous reference."
+ (interactive)
+ (when (null slime-previous-location-function)
+ (error "No context for finding locations."))
+ (funcall slime-previous-location-function))
+
+(defun slime-recompile-xref (&optional raw-prefix-arg)
+ (interactive "P")
+ (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg)))
+ (let ((location (slime-xref-location-at-point))
+ (dspec (slime-xref-dspec-at-point)))
+ (slime-recompile-locations
+ (list location)
+ (slime-rcurry #'slime-xref-recompilation-cont
+ (list dspec) (current-buffer))))))
+
+(defun slime-recompile-all-xrefs (&optional raw-prefix-arg)
+ (interactive "P")
+ (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg)))
+ (let ((dspecs) (locations))
+ (dolist (xref (slime-all-xrefs))
+ (when (slime-xref-has-location-p xref)
+ (push (slime-xref.dspec xref) dspecs)
+ (push (slime-xref.location xref) locations)))
+ (slime-recompile-locations
+ locations
+ (slime-rcurry #'slime-xref-recompilation-cont
+ dspecs (current-buffer))))))
+
+(defun slime-xref-recompilation-cont (results dspecs buffer)
+ ;; Extreme long-windedness to insert status of recompilation;
+ ;; sometimes Elisp resembles more of an Ewwlisp.
+
+ ;; FIXME: Should probably throw out the whole recompilation cruft
+ ;; anyway. -- helmut
+ ;; TODO: next iteration of fixme cleanup this is going in a contrib -- jt
+ (with-current-buffer buffer
+ (slime-compilation-finished (slime-aggregate-compilation-results results))
+ (save-excursion
+ (slime-xref-insert-recompilation-flags
+ dspecs (cl-loop for r in results collect
+ (or (slime-compilation-result.successp r)
+ (and (slime-compilation-result.notes r)
+ :complained)))))))
+
+(defun slime-aggregate-compilation-results (results)
+ `(:compilation-result
+ ,(cl-reduce #'append (mapcar #'slime-compilation-result.notes results))
+ ,(cl-every #'slime-compilation-result.successp results)
+ ,(cl-reduce #'+ (mapcar #'slime-compilation-result.duration results))))
+
+(defun slime-xref-insert-recompilation-flags (dspecs compilation-results)
+ (let* ((buffer-read-only nil)
+ (max-column (slime-column-max)))
+ (goto-char (point-min))
+ (cl-loop for dspec in dspecs
+ for result in compilation-results
+ do (save-excursion
+ (cl-loop for dspec2 = (progn (search-forward dspec)
+ (slime-xref-dspec-at-point))
+ until (equal dspec2 dspec))
+ (end-of-line) ; skip old status information.
+ (insert-char ?\ (1+ (- max-column (current-column))))
+ (insert (format "[%s]"
+ (cl-case result
+ ((t) :success)
+ ((nil) :failure)
+ (t result))))))))
+
+
+;;;; Macroexpansion
+
+(define-minor-mode slime-macroexpansion-minor-mode
+ "SLIME mode for macroexpansion"
+ nil
+ " Macroexpand"
+ '(("g" . slime-macroexpand-again)))
+
+(cl-macrolet ((remap (from to)
+ `(dolist (mapping
+ (where-is-internal ,from slime-mode-map))
+ (define-key slime-macroexpansion-minor-mode-map
+ mapping ,to))))
+ (remap 'slime-macroexpand-1 'slime-macroexpand-1-inplace)
+ (remap 'slime-macroexpand-all 'slime-macroexpand-all-inplace)
+ (remap 'slime-compiler-macroexpand-1 'slime-compiler-macroexpand-1-inplace)
+ (remap 'slime-expand-1
+ 'slime-expand-1-inplace)
+ (remap 'advertised-undo 'slime-macroexpand-undo)
+ (remap 'undo 'slime-macroexpand-undo))
+
+(defun slime-macroexpand-undo (&optional arg)
+ (interactive)
+ ;; Emacs 22.x introduced `undo-only' which
+ ;; works by binding `undo-no-redo' to t. We do
+ ;; it this way so we don't break prior Emacs
+ ;; versions.
+ (cl-macrolet ((undo-only (arg) `(let ((undo-no-redo t)) (undo ,arg))))
+ (let ((inhibit-read-only t))
+ (when (fboundp 'slime-remove-edits)
+ (slime-remove-edits (point-min) (point-max)))
+ (undo-only arg))))
+
+(defvar slime-eval-macroexpand-expression nil
+ "Specifies the last macroexpansion preformed.
+This variable specifies both what was expanded and how.")
+
+(defun slime-eval-macroexpand (expander &optional string)
+ (let ((string (or string (slime-sexp-at-point-or-error))))
+ (setq slime-eval-macroexpand-expression `(,expander ,string))
+ (slime-eval-async slime-eval-macroexpand-expression
+ #'slime-initialize-macroexpansion-buffer)))
+
+(defun slime-macroexpand-again ()
+ "Reperform the last macroexpansion."
+ (interactive)
+ (slime-eval-async slime-eval-macroexpand-expression
+ (slime-rcurry #'slime-initialize-macroexpansion-buffer
+ (current-buffer))))
+
+(defun slime-initialize-macroexpansion-buffer (expansion &optional buffer)
+ (pop-to-buffer (or buffer (slime-create-macroexpansion-buffer)))
+ (setq buffer-undo-list nil) ; Get rid of undo information from
+ ; previous expansions.
+ (let ((inhibit-read-only t)
+ (buffer-undo-list t)) ; Make the initial insertion not be undoable.
+ (erase-buffer)
+ (insert expansion)
+ (goto-char (point-min))
+ (font-lock-fontify-buffer)))
+
+(defun slime-create-macroexpansion-buffer ()
+ (let ((name (slime-buffer-name :macroexpansion)))
+ (slime-with-popup-buffer (name :package t :connection t
+ :mode 'lisp-mode)
+ (slime-mode 1)
+ (slime-macroexpansion-minor-mode 1)
+ (setq font-lock-keywords-case-fold-search t)
+ (current-buffer))))
+
+(defun slime-eval-macroexpand-inplace (expander)
+ "Substitute the sexp at point with its macroexpansion.
+
+NB: Does not affect slime-eval-macroexpand-expression"
+ (interactive)
+ (let* ((bounds (or (slime-bounds-of-sexp-at-point)
+ (user-error "No sexp at point"))))
+ (lexical-let* ((start (copy-marker (car bounds)))
+ (end (copy-marker (cdr bounds)))
+ (point (point))
+ (package (slime-current-package))
+ (buffer (current-buffer)))
+ (slime-eval-async
+ `(,expander ,(buffer-substring-no-properties start end))
+ (lambda (expansion)
+ (with-current-buffer buffer
+ (let ((buffer-read-only nil))
+ (when (fboundp 'slime-remove-edits)
+ (slime-remove-edits (point-min) (point-max)))
+ (goto-char start)
+ (delete-region start end)
+ (slime-insert-indented expansion)
+ (goto-char point))))))))
+
+(defun slime-macroexpand-1 (&optional repeatedly)
+ "Display the macro expansion of the form starting at point.
+The form is expanded with CL:MACROEXPAND-1 or, if a prefix
+argument is given, with CL:MACROEXPAND."
+ (interactive "P")
+ (slime-eval-macroexpand
+ (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1)))
+
+(defun slime-macroexpand-1-inplace (&optional repeatedly)
+ (interactive "P")
+ (slime-eval-macroexpand-inplace
+ (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1)))
+
+(defun slime-macroexpand-all ()
+ "Display the recursively macro expanded sexp starting at
+point."
+ (interactive)
+ (slime-eval-macroexpand 'swank:swank-macroexpand-all))
+
+(defun slime-macroexpand-all-inplace ()
+ "Display the recursively macro expanded sexp starting at point."
+ (interactive)
+ (slime-eval-macroexpand-inplace 'swank:swank-macroexpand-all))
+
+(defun slime-compiler-macroexpand-1 (&optional repeatedly)
+ "Display the compiler-macro expansion of sexp starting at point."
+ (interactive "P")
+ (slime-eval-macroexpand
+ (if repeatedly
+ 'swank:swank-compiler-macroexpand
+ 'swank:swank-compiler-macroexpand-1)))
+
+(defun slime-compiler-macroexpand-1-inplace (&optional repeatedly)
+ "Display the compiler-macro expansion of sexp starting at point."
+ (interactive "P")
+ (slime-eval-macroexpand-inplace
+ (if repeatedly
+ 'swank:swank-compiler-macroexpand
+ 'swank:swank-compiler-macroexpand-1)))
+
+(defun slime-expand-1 (&optional repeatedly)
+ "Display the macro expansion of the form starting at point.
+The form is expanded with CL:MACROEXPAND-1 or, if a prefix
+argument is given, with CL:MACROEXPAND. If the form denotes a
+compiler macro, SWANK/BACKEND:COMPILER-MACROEXPAND or
+SWANK/BACKEND:COMPILER-MACROEXPAND-1 are used instead."
+ (interactive "P")
+ (slime-eval-macroexpand
+ (if repeatedly
+ 'swank:swank-expand
+ 'swank:swank-expand-1)))
+
+(defun slime-expand-1-inplace (&optional repeatedly)
+ "Display the macro expansion of the form at point.
+The form is expanded with CL:MACROEXPAND-1 or, if a prefix
+argument is given, with CL:MACROEXPAND."
+ (interactive "P")
+ (slime-eval-macroexpand-inplace
+ (if repeatedly
+ 'swank:swank-expand
+ 'swank:swank-expand-1)))
+
+(defun slime-format-string-expand (&optional string)
+ "Expand the format-string at point and display it."
+ (interactive (list (or (and (not current-prefix-arg)
+ (slime-string-at-point))
+ (slime-read-from-minibuffer "Expand format: "
+ (slime-string-at-point)))))
+ (slime-eval-macroexpand 'swank:swank-format-string-expand string))
+
+
+;;;; Subprocess control
+
+(defun slime-interrupt ()
+ "Interrupt Lisp."
+ (interactive)
+ (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint))
+ (t (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread)))))
+
+(defun slime-quit ()
+ (error "Not implemented properly. Use `slime-interrupt' instead."))
+
+(defun slime-quit-lisp (&optional kill)
+ "Quit lisp, kill the inferior process and associated buffers."
+ (interactive "P")
+ (slime-quit-lisp-internal (slime-connection) 'slime-quit-sentinel kill))
+
+(defun slime-quit-lisp-internal (connection sentinel kill)
+ (let ((slime-dispatching-connection connection))
+ (slime-eval-async '(swank:quit-lisp))
+ (let* ((process (slime-inferior-process connection)))
+ (set-process-filter connection nil)
+ (set-process-sentinel connection sentinel)
+ (when (and kill process)
+ (sleep-for 0.2)
+ (unless (memq (process-status process) '(exit signal))
+ (kill-process process))))))
+
+(defun slime-quit-sentinel (process _message)
+ (cl-assert (process-status process) 'closed)
+ (let* ((inferior (slime-inferior-process process))
+ (inferior-buffer (if inferior (process-buffer inferior))))
+ (when inferior (delete-process inferior))
+ (when inferior-buffer (kill-buffer inferior-buffer))
+ (slime-net-close process)
+ (message "Connection closed.")))
+
+
+;;;; Debugger (SLDB)
+
+(defvar sldb-hook nil
+ "Hook run on entry to the debugger.")
+
+(defcustom sldb-initial-restart-limit 6
+ "Maximum number of restarts to display initially."
+ :group 'slime-debugger
+ :type 'integer)
+
+
+;;;;; Local variables in the debugger buffer
+
+;; Small helper.
+(defun slime-make-variables-buffer-local (&rest variables)
+ (mapcar #'make-variable-buffer-local variables))
+
+(slime-make-variables-buffer-local
+ (defvar sldb-condition nil
+ "A list (DESCRIPTION TYPE) describing the condition being debugged.")
+
+ (defvar sldb-restarts nil
+ "List of (NAME DESCRIPTION) for each available restart.")
+
+ (defvar sldb-level nil
+ "Current debug level (recursion depth) displayed in buffer.")
+
+ (defvar sldb-backtrace-start-marker nil
+ "Marker placed at the first frame of the backtrace.")
+
+ (defvar sldb-restart-list-start-marker nil
+ "Marker placed at the first restart in the restart list.")
+
+ (defvar sldb-continuations nil
+ "List of ids for pending continuation."))
+
+;;;;; SLDB macros
+
+;; some macros that we need to define before the first use
+
+(defmacro sldb-in-face (name string)
+ "Return STRING propertised with face sldb-NAME-face."
+ (declare (indent 1))
+ (let ((facename (intern (format "sldb-%s-face" (symbol-name name))))
+ (var (cl-gensym "string")))
+ `(let ((,var ,string))
+ (slime-add-face ',facename ,var)
+ ,var)))
+
+
+;;;;; sldb-mode
+
+(defvar sldb-mode-syntax-table
+ (let ((table (copy-syntax-table lisp-mode-syntax-table)))
+ ;; We give < and > parenthesis syntax, so that #< ... > is treated
+ ;; as a balanced expression. This enables autodoc-mode to match
+ ;; #<unreadable> actual arguments in the backtraces with formal
+ ;; arguments of the function. (For Lisp mode, this is not
+ ;; desirable, since we do not wish to get a mismatched paren
+ ;; highlighted everytime we type < or >.)
+ (modify-syntax-entry ?< "(" table)
+ (modify-syntax-entry ?> ")" table)
+ table)
+ "Syntax table for SLDB mode.")
+
+(define-derived-mode sldb-mode fundamental-mode "sldb"
+ "Superior lisp debugger mode.
+In addition to ordinary SLIME commands, the following are
+available:\\<sldb-mode-map>
+
+Commands to examine the selected frame:
+ \\[sldb-toggle-details] - toggle details (local bindings, CATCH tags)
+ \\[sldb-show-source] - view source for the frame
+ \\[sldb-eval-in-frame] - eval in frame
+ \\[sldb-pprint-eval-in-frame] - eval in frame, pretty-print result
+ \\[sldb-disassemble] - disassemble
+ \\[sldb-inspect-in-frame] - inspect
+
+Commands to invoke restarts:
+ \\[sldb-quit] - quit
+ \\[sldb-abort] - abort
+ \\[sldb-continue] - continue
+ \\[sldb-invoke-restart-0]-\\[sldb-invoke-restart-9] - restart shortcuts
+ \\[sldb-invoke-restart-by-name] - invoke restart by name
+
+Commands to navigate frames:
+ \\[sldb-down] - down
+ \\[sldb-up] - up
+ \\[sldb-details-down] - down, with details
+ \\[sldb-details-up] - up, with details
+ \\[sldb-cycle] - cycle between restarts & backtrace
+ \\[sldb-beginning-of-backtrace] - beginning of backtrace
+ \\[sldb-end-of-backtrace] - end of backtrace
+
+Miscellaneous commands:
+ \\[sldb-restart-frame] - restart frame
+ \\[sldb-return-from-frame] - return from frame
+ \\[sldb-step] - step
+ \\[sldb-break-with-default-debugger] - switch to native debugger
+ \\[sldb-break-with-system-debugger] - switch to system debugger (gdb)
+ \\[slime-interactive-eval] - eval
+ \\[sldb-inspect-condition] - inspect signalled condition
+
+Full list of commands:
+
+\\{sldb-mode-map}"
+ (erase-buffer)
+ (set-syntax-table sldb-mode-syntax-table)
+ (slime-set-truncate-lines)
+ ;; Make original slime-connection "sticky" for SLDB commands in this buffer
+ (setq slime-buffer-connection (slime-connection)))
+
+(set-keymap-parent sldb-mode-map slime-parent-map)
+
+(slime-define-keys sldb-mode-map
+
+ ((kbd "RET") 'sldb-default-action)
+ ("\C-m" 'sldb-default-action)
+ ([return] 'sldb-default-action)
+ ([mouse-2] 'sldb-default-action/mouse)
+ ([follow-link] 'mouse-face)
+ ("\C-i" 'sldb-cycle)
+ ("h" 'describe-mode)
+ ("v" 'sldb-show-source)
+ ("e" 'sldb-eval-in-frame)
+ ("d" 'sldb-pprint-eval-in-frame)
+ ("D" 'sldb-disassemble)
+ ("i" 'sldb-inspect-in-frame)
+ ("n" 'sldb-down)
+ ("p" 'sldb-up)
+ ("\M-n" 'sldb-details-down)
+ ("\M-p" 'sldb-details-up)
+ ("<" 'sldb-beginning-of-backtrace)
+ (">" 'sldb-end-of-backtrace)
+ ("t" 'sldb-toggle-details)
+ ("r" 'sldb-restart-frame)
+ ("I" 'sldb-invoke-restart-by-name)
+ ("R" 'sldb-return-from-frame)
+ ("c" 'sldb-continue)
+ ("s" 'sldb-step)
+ ("x" 'sldb-next)
+ ("o" 'sldb-out)
+ ("b" 'sldb-break-on-return)
+ ("a" 'sldb-abort)
+ ("q" 'sldb-quit)
+ ("A" 'sldb-break-with-system-debugger)
+ ("B" 'sldb-break-with-default-debugger)
+ ("P" 'sldb-print-condition)
+ ("C" 'sldb-inspect-condition)
+ (":" 'slime-interactive-eval)
+ ("\C-c\C-c" 'sldb-recompile-frame-source))
+
+;; Keys 0-9 are shortcuts to invoke particular restarts.
+(dotimes (number 10)
+ (let ((fname (intern (format "sldb-invoke-restart-%S" number)))
+ (docstring (format "Invoke restart numbered %S." number)))
+ (eval `(defun ,fname ()
+ ,docstring
+ (interactive)
+ (sldb-invoke-restart ,number)))
+ (define-key sldb-mode-map (number-to-string number) fname)))
+
+
+;;;;; SLDB buffer creation & update
+
+(defun sldb-buffers (&optional connection)
+ "Return a list of all sldb buffers (belonging to CONNECTION.)"
+ (if connection
+ (slime-filter-buffers (lambda ()
+ (and (eq slime-buffer-connection connection)
+ (eq major-mode 'sldb-mode))))
+ (slime-filter-buffers (lambda () (eq major-mode 'sldb-mode)))))
+
+(defun sldb-find-buffer (thread &optional connection)
+ (let ((connection (or connection (slime-connection))))
+ (cl-find-if (lambda (buffer)
+ (with-current-buffer buffer
+ (and (eq slime-buffer-connection connection)
+ (eq slime-current-thread thread))))
+ (sldb-buffers))))
+
+(defun sldb-get-default-buffer ()
+ "Get a sldb buffer.
+The chosen buffer the default connection's it if exists."
+ (car (sldb-buffers slime-default-connection)))
+
+(defun sldb-get-buffer (thread &optional connection)
+ "Find or create a sldb-buffer for THREAD."
+ (let ((connection (or connection (slime-connection))))
+ (or (sldb-find-buffer thread connection)
+ (let ((name (format "*sldb %s/%s*" (slime-connection-name) thread)))
+ (with-current-buffer (generate-new-buffer name)
+ (setq slime-buffer-connection connection
+ slime-current-thread thread)
+ (current-buffer))))))
+
+(defun sldb-debugged-continuations (connection)
+ "Return the all debugged continuations for CONNECTION across SLDB buffers."
+ (cl-loop for b in (sldb-buffers)
+ append (with-current-buffer b
+ (and (eq slime-buffer-connection connection)
+ sldb-continuations))))
+
+(defun sldb-setup (thread level condition restarts frames conts)
+ "Setup a new SLDB buffer.
+CONDITION is a string describing the condition to debug.
+RESTARTS is a list of strings (NAME DESCRIPTION) for each available restart.
+FRAMES is a list (NUMBER DESCRIPTION &optional PLIST) describing the initial
+portion of the backtrace. Frames are numbered from 0.
+CONTS is a list of pending Emacs continuations."
+ (with-current-buffer (sldb-get-buffer thread)
+ (cl-assert (if (equal sldb-level level)
+ (equal sldb-condition condition)
+ t)
+ () "Bug: sldb-level is equal but condition differs\n%s\n%s"
+ sldb-condition condition)
+ (unless (equal sldb-level level)
+ (setq buffer-read-only nil)
+ (sldb-mode)
+ (setq slime-current-thread thread)
+ (setq sldb-level level)
+ (setq mode-name (format "sldb[%d]" sldb-level))
+ (setq sldb-condition condition)
+ (setq sldb-restarts restarts)
+ (setq sldb-continuations conts)
+ (sldb-insert-condition condition)
+ (insert "\n\n" (sldb-in-face section "Restarts:") "\n")
+ (setq sldb-restart-list-start-marker (point-marker))
+ (sldb-insert-restarts restarts 0 sldb-initial-restart-limit)
+ (insert "\n" (sldb-in-face section "Backtrace:") "\n")
+ (setq sldb-backtrace-start-marker (point-marker))
+ (save-excursion
+ (if frames
+ (sldb-insert-frames (sldb-prune-initial-frames frames) t)
+ (insert "[No backtrace]")))
+ (run-hooks 'sldb-hook)
+ (set-syntax-table lisp-mode-syntax-table))
+ ;; FIXME: remove when dropping Emacs23 support
+ (let ((saved (selected-window)))
+ (pop-to-buffer (current-buffer))
+ (set-window-parameter (selected-window) 'sldb-restore saved))
+ (unless noninteractive ; needed for tests in batch-mode
+ (slime--display-region (point-min) (point)))
+ (setq buffer-read-only t)
+ (when (and slime-stack-eval-tags
+ ;; (y-or-n-p "Enter recursive edit? ")
+ )
+ (message "Entering recursive edit..")
+ (recursive-edit))))
+
+(defun sldb-activate (thread level select)
+ "Display the debugger buffer for THREAD.
+If LEVEL isn't the same as in the buffer reinitialize the buffer."
+ (or (let ((buffer (sldb-find-buffer thread)))
+ (when buffer
+ (with-current-buffer buffer
+ (when (equal sldb-level level)
+ (when select (pop-to-buffer (current-buffer)))
+ t))))
+ (sldb-reinitialize thread level)))
+
+(defun sldb-reinitialize (thread level)
+ (slime-rex (thread level)
+ ('(swank:debugger-info-for-emacs 0 10)
+ nil thread)
+ ((:ok result)
+ (apply #'sldb-setup thread level result))))
+
+(defun sldb-exit (thread _level &optional stepping)
+ "Exit from the debug level LEVEL."
+ (let ((sldb (sldb-find-buffer thread)))
+ (when sldb
+ (with-current-buffer sldb
+ (cond (stepping
+ (setq sldb-level nil)
+ (run-with-timer 0.4 nil 'sldb-close-step-buffer sldb))
+ ((not (eq sldb (window-buffer (selected-window))))
+ ;; A different window selection means an indirect,
+ ;; non-interactive exit, we just kill the sldb buffer.
+ (kill-buffer))
+ (t
+ ;; An interactive exit should restore configuration per
+ ;; `quit-window's protocol. FIXME: remove
+ ;; `previous-window' hack when dropping Emacs23 support
+ (let ((previous-window (window-parameter (selected-window)
+ 'sldb-restore)))
+ (quit-window t)
+ (if (and (not (>= emacs-major-version 24))
+ (window-live-p previous-window))
+ (select-window previous-window)))))))))
+
+(defun sldb-close-step-buffer (buffer)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (when (not sldb-level)
+ (quit-window t)))))
+
+
+;;;;;; SLDB buffer insertion
+
+(defun sldb-insert-condition (condition)
+ "Insert the text for CONDITION.
+CONDITION should be a list (MESSAGE TYPE EXTRAS).
+EXTRAS is currently used for the stepper."
+ (cl-destructuring-bind (message type extras) condition
+ (slime-insert-propertized '(sldb-default-action sldb-inspect-condition)
+ (sldb-in-face topline message)
+ "\n"
+ (sldb-in-face condition type))
+ (sldb-dispatch-extras extras)))
+
+(defvar sldb-extras-hooks)
+
+(defun sldb-dispatch-extras (extras)
+ ;; this is (mis-)used for the stepper
+ (dolist (extra extras)
+ (slime-dcase extra
+ ((:show-frame-source n)
+ (sldb-show-frame-source n))
+ (t
+ (or (run-hook-with-args-until-success 'sldb-extras-hooks extra)
+ ;;(error "Unhandled extra element:" extra)
+ )))))
+
+(defun sldb-insert-restarts (restarts start count)
+ "Insert RESTARTS and add the needed text props
+RESTARTS should be a list ((NAME DESCRIPTION) ...)."
+ (let* ((len (length restarts))
+ (end (if count (min (+ start count) len) len)))
+ (cl-loop for (name string) in (cl-subseq restarts start end)
+ for number from start
+ do (slime-insert-propertized
+ `(,@nil restart ,number
+ sldb-default-action sldb-invoke-restart
+ mouse-face highlight)
+ " " (sldb-in-face restart-number (number-to-string number))
+ ": [" (sldb-in-face restart-type name) "] "
+ (sldb-in-face restart string))
+ (insert "\n"))
+ (when (< end len)
+ (let ((pos (point)))
+ (slime-insert-propertized
+ (list 'sldb-default-action
+ (slime-rcurry #'sldb-insert-more-restarts restarts pos end))
+ " --more--\n")))))
+
+(defun sldb-insert-more-restarts (restarts position start)
+ (goto-char position)
+ (let ((inhibit-read-only t))
+ (delete-region position (1+ (line-end-position)))
+ (sldb-insert-restarts restarts start nil)))
+
+(defun sldb-frame.string (frame)
+ (cl-destructuring-bind (_ str &optional _) frame str))
+
+(defun sldb-frame.number (frame)
+ (cl-destructuring-bind (n _ &optional _) frame n))
+
+(defun sldb-frame.plist (frame)
+ (cl-destructuring-bind (_ _ &optional plist) frame plist))
+
+(defun sldb-frame-restartable-p (frame)
+ (and (plist-get (sldb-frame.plist frame) :restartable) t))
+
+(defun sldb-prune-initial-frames (frames)
+ "Return the prefix of FRAMES to initially present to the user.
+Regexp heuristics are used to avoid showing SWANK-internal frames."
+ (let* ((case-fold-search t)
+ (rx "^\\([() ]\\|lambda\\)*swank\\>"))
+ (or (cl-loop for frame in frames
+ until (string-match rx (sldb-frame.string frame))
+ collect frame)
+ frames)))
+
+(defun sldb-insert-frames (frames more)
+ "Insert FRAMES into buffer.
+If MORE is non-nil, more frames are on the Lisp stack."
+ (mapc #'sldb-insert-frame frames)
+ (when more
+ (slime-insert-propertized
+ `(,@nil sldb-default-action sldb-fetch-more-frames
+ sldb-previous-frame-number
+ ,(sldb-frame.number (cl-first (last frames)))
+ point-entered sldb-fetch-more-frames
+ start-open t
+ face sldb-section-face
+ mouse-face highlight)
+ " --more--")
+ (insert "\n")))
+
+(defun sldb-compute-frame-face (frame)
+ (if (sldb-frame-restartable-p frame)
+ 'sldb-restartable-frame-line-face
+ 'sldb-frame-line-face))
+
+(defun sldb-insert-frame (frame &optional face)
+ "Insert FRAME with FACE at point.
+If FACE is nil, `sldb-compute-frame-face' is used to determine the face."
+ (setq face (or face (sldb-compute-frame-face frame)))
+ (let ((number (sldb-frame.number frame))
+ (string (sldb-frame.string frame))
+ (props `(frame ,frame sldb-default-action sldb-toggle-details)))
+ (slime-propertize-region props
+ (slime-propertize-region '(mouse-face highlight)
+ (insert " " (sldb-in-face frame-label (format "%2d:" number)) " ")
+ (slime-insert-indented
+ (slime-add-face face string)))
+ (insert "\n"))))
+
+(defun sldb-fetch-more-frames (&rest _)
+ "Fetch more backtrace frames.
+Called on the `point-entered' text-property hook."
+ (let ((inhibit-point-motion-hooks t)
+ (inhibit-read-only t)
+ (prev (get-text-property (point) 'sldb-previous-frame-number)))
+ ;; we may be called twice, PREV is nil the second time
+ (when prev
+ (let* ((count 40)
+ (from (1+ prev))
+ (to (+ from count))
+ (frames (slime-eval `(swank:backtrace ,from ,to)))
+ (more (slime-length= frames count))
+ (pos (point)))
+ (delete-region (line-beginning-position) (point-max))
+ (sldb-insert-frames frames more)
+ (goto-char pos)))))
+
+
+;;;;;; SLDB examining text props
+
+(defun sldb-restart-at-point ()
+ (or (get-text-property (point) 'restart)
+ (error "No restart at point")))
+
+(defun sldb-frame-number-at-point ()
+ (let ((frame (get-text-property (point) 'frame)))
+ (cond (frame (car frame))
+ (t (error "No frame at point")))))
+
+(defun sldb-var-number-at-point ()
+ (let ((var (get-text-property (point) 'var)))
+ (cond (var var)
+ (t (error "No variable at point")))))
+
+(defun sldb-previous-frame-number ()
+ (save-excursion
+ (sldb-backward-frame)
+ (sldb-frame-number-at-point)))
+
+(defun sldb-frame-details-visible-p ()
+ (and (get-text-property (point) 'frame)
+ (get-text-property (point) 'details-visible-p)))
+
+(defun sldb-frame-region ()
+ (slime-property-bounds 'frame))
+
+(defun sldb-forward-frame ()
+ (goto-char (next-single-char-property-change (point) 'frame)))
+
+(defun sldb-backward-frame ()
+ (when (> (point) sldb-backtrace-start-marker)
+ (goto-char (previous-single-char-property-change
+ (if (get-text-property (point) 'frame)
+ (car (sldb-frame-region))
+ (point))
+ 'frame
+ nil sldb-backtrace-start-marker))))
+
+(defun sldb-goto-last-frame ()
+ (goto-char (point-max))
+ (while (not (get-text-property (point) 'frame))
+ (goto-char (previous-single-property-change (point) 'frame))
+ ;; Recenter to bottom of the window; -2 to account for the
+ ;; empty last line displayed in sldb buffers.
+ (recenter -2)))
+
+(defun sldb-beginning-of-backtrace ()
+ "Goto the first frame."
+ (interactive)
+ (goto-char sldb-backtrace-start-marker))
+
+
+;;;;;; SLDB recenter & redisplay
+;; not sure yet, whether this is a good idea.
+;;
+;; jt: seconded. Only `sldb-show-frame-details' and
+;; `sldb-hide-frame-details' use this. They could avoid it by not
+;; removing and reinserting the frame's name line.
+(defmacro slime-save-coordinates (origin &rest body)
+ "Restore line and column relative to ORIGIN, after executing BODY.
+
+This is useful if BODY deletes and inserts some text but we want to
+preserve the current row and column as closely as possible."
+ (let ((base (make-symbol "base"))
+ (goal (make-symbol "goal"))
+ (mark (make-symbol "mark")))
+ `(let* ((,base ,origin)
+ (,goal (slime-coordinates ,base))
+ (,mark (point-marker)))
+ (set-marker-insertion-type ,mark t)
+ (prog1 (save-excursion ,@body)
+ (slime-restore-coordinate ,base ,goal ,mark)))))
+
+(put 'slime-save-coordinates 'lisp-indent-function 1)
+
+(defun slime-coordinates (origin)
+ ;; Return a pair (X . Y) for the column and line distance to ORIGIN.
+ (let ((y (slime-count-lines origin (point)))
+ (x (save-excursion
+ (- (current-column)
+ (progn (goto-char origin) (current-column))))))
+ (cons x y)))
+
+(defun slime-restore-coordinate (base goal limit)
+ ;; Move point to GOAL. Coordinates are relative to BASE.
+ ;; Don't move beyond LIMIT.
+ (save-restriction
+ (narrow-to-region base limit)
+ (goto-char (point-min))
+ (let ((col (current-column)))
+ (forward-line (cdr goal))
+ (when (and (eobp) (bolp) (not (bobp)))
+ (backward-char))
+ (move-to-column (+ col (car goal))))))
+
+(defun slime-count-lines (start end)
+ "Return the number of lines between START and END.
+This is 0 if START and END at the same line."
+ (- (count-lines start end)
+ (if (save-excursion (goto-char end) (bolp)) 0 1)))
+
+
+;;;;; SLDB commands
+
+(defun sldb-default-action ()
+ "Invoke the action at point."
+ (interactive)
+ (let ((fn (get-text-property (point) 'sldb-default-action)))
+ (if fn (funcall fn))))
+
+(defun sldb-default-action/mouse (event)
+ "Invoke the action pointed at by the mouse."
+ (interactive "e")
+ (cl-destructuring-bind (_mouse-1 (_w pos &rest ignore)) event
+ (save-excursion
+ (goto-char pos)
+ (let ((fn (get-text-property (point) 'sldb-default-action)))
+ (if fn (funcall fn))))))
+
+(defun sldb-cycle ()
+ "Cycle between restart list and backtrace."
+ (interactive)
+ (let ((pt (point)))
+ (cond ((< pt sldb-restart-list-start-marker)
+ (goto-char sldb-restart-list-start-marker))
+ ((< pt sldb-backtrace-start-marker)
+ (goto-char sldb-backtrace-start-marker))
+ (t
+ (goto-char sldb-restart-list-start-marker)))))
+
+(defun sldb-end-of-backtrace ()
+ "Fetch the entire backtrace and go to the last frame."
+ (interactive)
+ (sldb-fetch-all-frames)
+ (sldb-goto-last-frame))
+
+(defun sldb-fetch-all-frames ()
+ (let ((inhibit-read-only t)
+ (inhibit-point-motion-hooks t))
+ (sldb-goto-last-frame)
+ (let ((last (sldb-frame-number-at-point)))
+ (goto-char (next-single-char-property-change (point) 'frame))
+ (delete-region (point) (point-max))
+ (save-excursion
+ (sldb-insert-frames (slime-eval `(swank:backtrace ,(1+ last) nil))
+ nil)))))
+
+
+;;;;;; SLDB show source
+
+(defun sldb-show-source ()
+ "Highlight the frame at point's expression in a source code buffer."
+ (interactive)
+ (sldb-show-frame-source (sldb-frame-number-at-point)))
+
+(defun sldb-show-frame-source (frame-number)
+ (slime-eval-async
+ `(swank:frame-source-location ,frame-number)
+ (lambda (source-location)
+ (slime-dcase source-location
+ ((:error message)
+ (message "%s" message)
+ (ding))
+ (t
+ (slime-show-source-location source-location t nil))))))
+
+(defun slime-show-source-location (source-location
+ &optional highlight recenter-arg)
+ "Go to SOURCE-LOCATION and display the buffer in the other window."
+ (slime-goto-source-location source-location)
+ ;; show the location, but don't hijack focus.
+ (slime--display-position (point) t recenter-arg)
+ (when highlight (slime-highlight-sexp)))
+
+(defun slime--display-position (pos other-window recenter-arg)
+ (with-selected-window (display-buffer (current-buffer) other-window)
+ (goto-char pos)
+ (recenter recenter-arg)))
+
+;; Set window-start so that the region from START to END becomes visible.
+;; START is inclusive; END is exclusive.
+(defun slime--adjust-window-start (start end)
+ (let* ((last (max start (1- end)))
+ (window-height (window-text-height))
+ (region-height (count-screen-lines start last t)))
+ ;; if needed, make the region visible
+ (when (or (not (pos-visible-in-window-p start))
+ (not (pos-visible-in-window-p last)))
+ (let* ((nlines (cond ((or (< start (window-start))
+ (>= region-height window-height))
+ 0)
+ (t
+ (- region-height)))))
+ (goto-char start)
+ (recenter nlines)))
+ (cl-assert (pos-visible-in-window-p start))
+ (cl-assert (or (pos-visible-in-window-p last)
+ (> region-height window-height)))
+ (cl-assert (pos-visible-in-window-p (1- (window-end nil t)) nil t))))
+
+;; move POS to visible region
+(defun slime--adjust-window-point (pos)
+ (cond ((pos-visible-in-window-p pos)
+ (goto-char pos))
+ ((< pos (window-start))
+ (goto-char (window-start)))
+ (t
+ (goto-char (1- (window-end nil t)))
+ (move-to-column 0)))
+ (cl-assert (pos-visible-in-window-p (point) nil t)))
+
+(defun slime--display-region (start end)
+ "Make the region from START to END visible.
+Minimize point motion."
+ (cl-assert (<= start end))
+ (cl-assert (eq (window-buffer (selected-window))
+ (current-buffer)))
+ (let ((pos (point)))
+ (slime--adjust-window-start start end)
+ (slime--adjust-window-point pos)))
+
+(defun slime-highlight-sexp (&optional start end)
+ "Highlight the first sexp after point."
+ (let ((start (or start (point)))
+ (end (or end (save-excursion (ignore-errors (forward-sexp)) (point)))))
+ (slime-flash-region start end)))
+
+(defun slime-highlight-line (&optional timeout)
+ (slime-flash-region (+ (line-beginning-position) (current-indentation))
+ (line-end-position)
+ timeout))
+
+
+;;;;;; SLDB toggle details
+
+(defun sldb-toggle-details (&optional on)
+ "Toggle display of details for the current frame.
+The details include local variable bindings and CATCH-tags."
+ (interactive)
+ (cl-assert (sldb-frame-number-at-point))
+ (let ((inhibit-read-only t)
+ (inhibit-point-motion-hooks t))
+ (if (or on (not (sldb-frame-details-visible-p)))
+ (sldb-show-frame-details)
+ (sldb-hide-frame-details))))
+
+(defun sldb-show-frame-details ()
+ ;; fetch and display info about local variables and catch tags
+ (cl-destructuring-bind (start end frame locals catches) (sldb-frame-details)
+ (slime-save-coordinates start
+ (delete-region start end)
+ (slime-propertize-region `(frame ,frame details-visible-p t)
+ (sldb-insert-frame frame (if (sldb-frame-restartable-p frame)
+ 'sldb-restartable-frame-line-face
+ ;; FIXME: can we somehow merge the two?
+ 'sldb-detailed-frame-line-face))
+ (let ((indent1 " ")
+ (indent2 " "))
+ (insert indent1 (sldb-in-face section
+ (if locals "Locals:" "[No Locals]")) "\n")
+ (sldb-insert-locals locals indent2 frame)
+ (when catches
+ (insert indent1 (sldb-in-face section "Catch-tags:") "\n")
+ (dolist (tag catches)
+ (slime-propertize-region `(catch-tag ,tag)
+ (insert indent2 (sldb-in-face catch-tag (format "%s" tag))
+ "\n"))))
+ (setq end (point)))))
+ (slime--display-region (point) end)))
+
+(defun sldb-frame-details ()
+ ;; Return a list (START END FRAME LOCALS CATCHES) for frame at point.
+ (let* ((frame (get-text-property (point) 'frame))
+ (num (car frame)))
+ (cl-destructuring-bind (start end) (sldb-frame-region)
+ (cl-list* start end frame
+ (slime-eval `(swank:frame-locals-and-catch-tags ,num))))))
+
+(defvar sldb-insert-frame-variable-value-function
+ 'sldb-insert-frame-variable-value)
+
+(defun sldb-insert-locals (vars prefix frame)
+ "Insert VARS and add PREFIX at the beginning of each inserted line.
+VAR should be a plist with the keys :name, :id, and :value."
+ (cl-loop for i from 0
+ for var in vars do
+ (cl-destructuring-bind (&key name id value) var
+ (slime-propertize-region
+ (list 'sldb-default-action 'sldb-inspect-var 'var i)
+ (insert prefix
+ (sldb-in-face local-name
+ (concat name (if (zerop id) "" (format "#%d" id))))
+ " = ")
+ (funcall sldb-insert-frame-variable-value-function
+ value frame i)
+ (insert "\n")))))
+
+(defun sldb-insert-frame-variable-value (value _frame _index)
+ (insert (sldb-in-face local-value value)))
+
+(defun sldb-hide-frame-details ()
+ ;; delete locals and catch tags, but keep the function name and args.
+ (cl-destructuring-bind (start end) (sldb-frame-region)
+ (let ((frame (get-text-property (point) 'frame)))
+ (slime-save-coordinates start
+ (delete-region start end)
+ (slime-propertize-region '(details-visible-p nil)
+ (sldb-insert-frame frame))))))
+
+(defun sldb-disassemble ()
+ "Disassemble the code for the current frame."
+ (interactive)
+ (let ((frame (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:sldb-disassemble ,frame)
+ (lambda (result)
+ (slime-show-description result nil)))))
+
+
+;;;;;; SLDB eval and inspect
+
+(defun sldb-eval-in-frame (frame string package)
+ "Prompt for an expression and evaluate it in the selected frame."
+ (interactive (sldb-read-form-for-frame "Eval in frame (%s)> "))
+ (slime-eval-async `(swank:eval-string-in-frame ,string ,frame ,package)
+ (if current-prefix-arg
+ 'slime-write-string
+ 'slime-display-eval-result)))
+
+(defun sldb-pprint-eval-in-frame (frame string package)
+ "Prompt for an expression, evaluate in selected frame, pretty-print result."
+ (interactive (sldb-read-form-for-frame "Eval in frame (%s)> "))
+ (slime-eval-async
+ `(swank:pprint-eval-string-in-frame ,string ,frame ,package)
+ (lambda (result)
+ (slime-show-description result nil))))
+
+(defun sldb-read-form-for-frame (fstring)
+ (let* ((frame (sldb-frame-number-at-point))
+ (pkg (slime-eval `(swank:frame-package-name ,frame))))
+ (list frame
+ (let ((slime-buffer-package pkg))
+ (slime-read-from-minibuffer (format fstring pkg)))
+ pkg)))
+
+(defun sldb-inspect-in-frame (string)
+ "Prompt for an expression and inspect it in the selected frame."
+ (interactive (list (slime-read-from-minibuffer
+ "Inspect in frame (evaluated): "
+ (slime-sexp-at-point))))
+ (let ((number (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:inspect-in-frame ,string ,number)
+ 'slime-open-inspector)))
+
+(defun sldb-inspect-var ()
+ (let ((frame (sldb-frame-number-at-point))
+ (var (sldb-var-number-at-point)))
+ (slime-eval-async `(swank:inspect-frame-var ,frame ,var)
+ 'slime-open-inspector)))
+
+(defun sldb-inspect-condition ()
+ "Inspect the current debugger condition."
+ (interactive)
+ (slime-eval-async '(swank:inspect-current-condition)
+ 'slime-open-inspector))
+
+(defun sldb-print-condition ()
+ (interactive)
+ (slime-eval-describe `(swank:sdlb-print-condition)))
+
+
+;;;;;; SLDB movement
+
+(defun sldb-down ()
+ "Select next frame."
+ (interactive)
+ (sldb-forward-frame))
+
+(defun sldb-up ()
+ "Select previous frame."
+ (interactive)
+ (sldb-backward-frame)
+ (when (= (point) sldb-backtrace-start-marker)
+ (recenter (1+ (count-lines (point-min) (point))))))
+
+(defun sldb-sugar-move (move-fn)
+ (let ((inhibit-read-only t))
+ (when (sldb-frame-details-visible-p) (sldb-hide-frame-details))
+ (funcall move-fn)
+ (sldb-show-source)
+ (sldb-toggle-details t)))
+
+(defun sldb-details-up ()
+ "Select previous frame and show details."
+ (interactive)
+ (sldb-sugar-move 'sldb-up))
+
+(defun sldb-details-down ()
+ "Select next frame and show details."
+ (interactive)
+ (sldb-sugar-move 'sldb-down))
+
+
+;;;;;; SLDB restarts
+
+(defun sldb-quit ()
+ "Quit to toplevel."
+ (interactive)
+ (cl-assert sldb-restarts () "sldb-quit called outside of sldb buffer")
+ (slime-rex () ('(swank:throw-to-toplevel))
+ ((:ok x) (error "sldb-quit returned [%s]" x))
+ ((:abort _))))
+
+(defun sldb-continue ()
+ "Invoke the \"continue\" restart."
+ (interactive)
+ (cl-assert sldb-restarts () "sldb-continue called outside of sldb buffer")
+ (slime-rex ()
+ ('(swank:sldb-continue))
+ ((:ok _)
+ (message "No restart named continue")
+ (ding))
+ ((:abort _))))
+
+(defun sldb-abort ()
+ "Invoke the \"abort\" restart."
+ (interactive)
+ (slime-eval-async '(swank:sldb-abort)
+ (lambda (v) (message "Restart returned: %S" v))))
+
+(defun sldb-invoke-restart (&optional number)
+ "Invoke a restart.
+Optional NUMBER (index into `sldb-restarts') specifies the
+restart to invoke, otherwise use the restart at point."
+ (interactive)
+ (let ((restart (or number (sldb-restart-at-point))))
+ (slime-rex ()
+ ((list 'swank:invoke-nth-restart-for-emacs sldb-level restart))
+ ((:ok value) (message "Restart returned: %s" value))
+ ((:abort _)))))
+
+(defun sldb-invoke-restart-by-name (restart-name)
+ (interactive (list (let ((completion-ignore-case t))
+ (completing-read "Restart: " sldb-restarts nil t
+ ""
+ 'sldb-invoke-restart-by-name))))
+ (sldb-invoke-restart (cl-position restart-name sldb-restarts
+ :test 'string= :key 'first)))
+
+(defun sldb-break-with-default-debugger (&optional dont-unwind)
+ "Enter default debugger."
+ (interactive "P")
+ (slime-rex ()
+ ((list 'swank:sldb-break-with-default-debugger
+ (not (not dont-unwind)))
+ nil slime-current-thread)
+ ((:abort _))))
+
+(defun sldb-break-with-system-debugger (&optional lightweight)
+ "Enter system debugger (gdb)."
+ (interactive "P")
+ (slime-attach-gdb slime-buffer-connection lightweight))
+
+(defun slime-attach-gdb (connection &optional lightweight)
+ "Run `gud-gdb'on the connection with PID `pid'.
+
+If `lightweight' is given, do not send any request to the
+inferior Lisp (e.g. to obtain default gdb config) but only
+operate from the Emacs side; intended for cases where the Lisp is
+truly screwed up."
+ (interactive
+ (list (slime-read-connection "Attach gdb to: " (slime-connection)) "P"))
+ (let ((pid (slime-pid connection))
+ (file (slime-lisp-implementation-program connection))
+ (commands (unless lightweight
+ (let ((slime-dispatching-connection connection))
+ (slime-eval `(swank:gdb-initial-commands))))))
+ (gud-gdb (format "gdb -p %d %s" pid (or file "")))
+ (with-current-buffer gud-comint-buffer
+ (dolist (cmd commands)
+ ;; First wait until gdb was initialized, then wait until current
+ ;; command was processed.
+ (while (not (looking-back comint-prompt-regexp nil))
+ (sit-for 0.01))
+ ;; We do not use `gud-call' because we want the initial commands
+ ;; to be displayed by the user so he knows what he's got.
+ (insert cmd)
+ (comint-send-input)))))
+
+(defun slime-read-connection (prompt &optional initial-value)
+ "Read a connection from the minibuffer.
+Return the net process, or nil."
+ (cl-assert (memq initial-value slime-net-processes))
+ (let* ((to-string (lambda (p)
+ (format "%s (pid %d)"
+ (slime-connection-name p) (slime-pid p))))
+ (candidates (mapcar (lambda (p) (cons (funcall to-string p) p))
+ slime-net-processes)))
+ (cdr (assoc (completing-read prompt candidates
+ nil t (funcall to-string initial-value))
+ candidates))))
+
+(defun sldb-step ()
+ "Step to next basic-block boundary."
+ (interactive)
+ (let ((frame (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:sldb-step ,frame))))
+
+(defun sldb-next ()
+ "Step over call."
+ (interactive)
+ (let ((frame (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:sldb-next ,frame))))
+
+(defun sldb-out ()
+ "Resume stepping after returning from this function."
+ (interactive)
+ (let ((frame (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:sldb-out ,frame))))
+
+(defun sldb-break-on-return ()
+ "Set a breakpoint at the current frame.
+The debugger is entered when the frame exits."
+ (interactive)
+ (let ((frame (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:sldb-break-on-return ,frame)
+ (lambda (msg) (message "%s" msg)))))
+
+(defun sldb-break (name)
+ "Set a breakpoint at the start of the function NAME."
+ (interactive (list (slime-read-symbol-name "Function: " t)))
+ (slime-eval-async `(swank:sldb-break ,name)
+ (lambda (msg) (message "%s" msg))))
+
+(defun sldb-return-from-frame (string)
+ "Reads an expression in the minibuffer and causes the function to
+return that value, evaluated in the context of the frame."
+ (interactive (list (slime-read-from-minibuffer "Return from frame: ")))
+ (let* ((number (sldb-frame-number-at-point)))
+ (slime-rex ()
+ ((list 'swank:sldb-return-from-frame number string))
+ ((:ok value) (message "%s" value))
+ ((:abort _)))))
+
+(defun sldb-restart-frame ()
+ "Causes the frame to restart execution with the same arguments as it
+was called originally."
+ (interactive)
+ (let* ((number (sldb-frame-number-at-point)))
+ (slime-rex ()
+ ((list 'swank:restart-frame number))
+ ((:ok value) (message "%s" value))
+ ((:abort _)))))
+
+(defun slime-toggle-break-on-signals ()
+ "Toggle the value of *break-on-signals*."
+ (interactive)
+ (slime-eval-async `(swank:toggle-break-on-signals)
+ (lambda (msg) (message "%s" msg))))
+
+
+;;;;;; SLDB recompilation commands
+
+(defun sldb-recompile-frame-source (&optional raw-prefix-arg)
+ (interactive "P")
+ (slime-eval-async
+ `(swank:frame-source-location ,(sldb-frame-number-at-point))
+ (lexical-let ((policy (slime-compute-policy raw-prefix-arg)))
+ (lambda (source-location)
+ (slime-dcase source-location
+ ((:error message)
+ (message "%s" message)
+ (ding))
+ (t
+ (let ((slime-compilation-policy policy))
+ (slime-recompile-location source-location))))))))
+
+
+;;;; Thread control panel
+
+(defvar slime-threads-buffer-name (slime-buffer-name :threads))
+(defvar slime-threads-buffer-timer nil)
+
+(defcustom slime-threads-update-interval nil
+ "Interval at which the list of threads will be updated."
+ :type '(choice
+ (number :value 0.5)
+ (const nil))
+ :group 'slime-ui)
+
+(defun slime-list-threads ()
+ "Display a list of threads."
+ (interactive)
+ (let ((name slime-threads-buffer-name))
+ (slime-with-popup-buffer (name :connection t
+ :mode 'slime-thread-control-mode)
+ (slime-update-threads-buffer)
+ (goto-char (point-min))
+ (when slime-threads-update-interval
+ (when slime-threads-buffer-timer
+ (cancel-timer slime-threads-buffer-timer))
+ (setq slime-threads-buffer-timer
+ (run-with-timer
+ slime-threads-update-interval
+ slime-threads-update-interval
+ 'slime-update-threads-buffer))))))
+
+(defun slime-quit-threads-buffer ()
+ (when slime-threads-buffer-timer
+ (cancel-timer slime-threads-buffer-timer))
+ (quit-window t)
+ (slime-eval-async `(swank:quit-thread-browser)))
+
+(defun slime-update-threads-buffer ()
+ (interactive)
+ (with-current-buffer slime-threads-buffer-name
+ (slime-eval-async '(swank:list-threads)
+ 'slime-display-threads)))
+
+(defun slime-move-point (position)
+ "Move point in the current buffer and in the window the buffer is displayed."
+ (let ((window (get-buffer-window (current-buffer) t)))
+ (goto-char position)
+ (when window
+ (set-window-point window position))))
+
+(defun slime-display-threads (threads)
+ (with-current-buffer slime-threads-buffer-name
+ (let* ((inhibit-read-only t)
+ (old-thread-id (get-text-property (point) 'thread-id))
+ (old-line (line-number-at-pos))
+ (old-column (current-column)))
+ (erase-buffer)
+ (slime-insert-threads threads)
+ (let ((new-line (cl-position old-thread-id (cdr threads)
+ :key #'car :test #'equal)))
+ (goto-char (point-min))
+ (forward-line (or new-line old-line))
+ (move-to-column old-column)
+ (slime-move-point (point))))))
+
+(defun slime-transpose-lists (list-of-lists)
+ (let ((ncols (length (car list-of-lists))))
+ (cl-loop for col-index below ncols
+ collect (cl-loop for row in list-of-lists
+ collect (elt row col-index)))))
+
+(defun slime-insert-table-row (line line-props col-props col-widths)
+ (slime-propertize-region line-props
+ (cl-loop for string in line
+ for col-prop in col-props
+ for width in col-widths do
+ (slime-insert-propertized col-prop string)
+ (insert-char ?\ (- width (length string))))))
+
+(defun slime-insert-table (rows header row-properties column-properties)
+ "Insert a \"table\" so that the columns are nicely aligned."
+ (let* ((ncols (length header))
+ (lines (cons header rows))
+ (widths (cl-loop for columns in (slime-transpose-lists lines)
+ collect (1+ (cl-loop for cell in columns
+ maximize (length cell)))))
+ (header-line (with-temp-buffer
+ (slime-insert-table-row
+ header nil (make-list ncols nil) widths)
+ (buffer-string))))
+ (cond ((boundp 'header-line-format)
+ (setq header-line-format header-line))
+ (t (insert header-line "\n")))
+ (cl-loop for line in rows for line-props in row-properties do
+ (slime-insert-table-row line line-props column-properties widths)
+ (insert "\n"))))
+
+(defvar slime-threads-table-properties
+ '(nil (face bold)))
+
+(defun slime-insert-threads (threads)
+ (let* ((labels (car threads))
+ (threads (cdr threads))
+ (header (cl-loop for label in labels collect
+ (capitalize (substring (symbol-name label) 1))))
+ (rows (cl-loop for thread in threads collect
+ (cl-loop for prop in thread collect
+ (format "%s" prop))))
+ (line-props (cl-loop for (id) in threads for i from 0
+ collect `(thread-index ,i thread-id ,id)))
+ (col-props (cl-loop for nil in labels for i from 0 collect
+ (nth i slime-threads-table-properties))))
+ (slime-insert-table rows header line-props col-props)))
+
+
+;;;;; Major mode
+
+(define-derived-mode slime-thread-control-mode fundamental-mode
+ "Threads"
+ "SLIME Thread Control Panel Mode.
+
+\\{slime-thread-control-mode-map}
+\\{slime-popup-buffer-mode-map}"
+ (when slime-truncate-lines
+ (set (make-local-variable 'truncate-lines) t))
+ (setq buffer-undo-list t))
+
+(slime-define-keys slime-thread-control-mode-map
+ ("a" 'slime-thread-attach)
+ ("d" 'slime-thread-debug)
+ ("g" 'slime-update-threads-buffer)
+ ("k" 'slime-thread-kill)
+ ("q" 'slime-quit-threads-buffer))
+
+(defun slime-thread-kill ()
+ (interactive)
+ (slime-eval `(cl:mapc 'swank:kill-nth-thread
+ ',(slime-get-properties 'thread-index)))
+ (call-interactively 'slime-update-threads-buffer))
+
+(defun slime-get-region-properties (prop start end)
+ (cl-loop for position = (if (get-text-property start prop)
+ start
+ (next-single-property-change start prop))
+ then (next-single-property-change position prop)
+ while (<= position end)
+ collect (get-text-property position prop)))
+
+(defun slime-get-properties (prop)
+ (if (use-region-p)
+ (slime-get-region-properties prop
+ (region-beginning)
+ (region-end))
+ (let ((value (get-text-property (point) prop)))
+ (when value
+ (list value)))))
+
+(defun slime-thread-attach ()
+ (interactive)
+ (let ((id (get-text-property (point) 'thread-index))
+ (file (slime-swank-port-file)))
+ (slime-eval-async `(swank:start-swank-server-in-thread ,id ,file)))
+ (slime-read-port-and-connect nil))
+
+(defun slime-thread-debug ()
+ (interactive)
+ (let ((id (get-text-property (point) 'thread-index)))
+ (slime-eval-async `(swank:debug-nth-thread ,id))))
+
+
+;;;;; Connection listing
+
+(define-derived-mode slime-connection-list-mode fundamental-mode
+ "Slime-Connections"
+ "SLIME Connection List Mode.
+
+\\{slime-connection-list-mode-map}
+\\{slime-popup-buffer-mode-map}"
+ (when slime-truncate-lines
+ (set (make-local-variable 'truncate-lines) t)))
+
+(slime-define-keys slime-connection-list-mode-map
+ ("d" 'slime-connection-list-make-default)
+ ("g" 'slime-update-connection-list)
+ ((kbd "C-k") 'slime-quit-connection-at-point)
+ ("R" 'slime-restart-connection-at-point))
+
+(defun slime-connection-at-point ()
+ (or (get-text-property (point) 'slime-connection)
+ (error "No connection at point")))
+
+(defun slime-quit-connection-at-point (connection)
+ (interactive (list (slime-connection-at-point)))
+ (let ((slime-dispatching-connection connection)
+ (end (time-add (current-time) (seconds-to-time 3))))
+ (slime-quit-lisp t)
+ (while (memq connection slime-net-processes)
+ (when (time-less-p end (current-time))
+ (message "Quit timeout expired. Disconnecting.")
+ (delete-process connection))
+ (sit-for 0 100)))
+ (slime-update-connection-list))
+
+(defun slime-restart-connection-at-point (connection)
+ (interactive (list (slime-connection-at-point)))
+ (let ((slime-dispatching-connection connection))
+ (slime-restart-inferior-lisp)))
+
+(defun slime-connection-list-make-default ()
+ "Make the connection at point the default connection."
+ (interactive)
+ (slime-select-connection (slime-connection-at-point))
+ (slime-update-connection-list))
+
+(defvar slime-connections-buffer-name (slime-buffer-name :connections))
+
+(defun slime-list-connections ()
+ "Display a list of all connections."
+ (interactive)
+ (slime-with-popup-buffer (slime-connections-buffer-name
+ :mode 'slime-connection-list-mode)
+ (slime-draw-connection-list)))
+
+(defun slime-update-connection-list ()
+ "Display a list of all connections."
+ (interactive)
+ (let ((pos (point))
+ (inhibit-read-only t))
+ (erase-buffer)
+ (slime-draw-connection-list)
+ (goto-char pos)))
+
+(defun slime-draw-connection-list ()
+ (let ((default-pos nil)
+ (default slime-default-connection)
+ (fstring "%s%2s %-10s %-17s %-7s %-s\n"))
+ (insert (format fstring " " "Nr" "Name" "Port" "Pid" "Type")
+ (format fstring " " "--" "----" "----" "---" "----"))
+ (dolist (p (reverse slime-net-processes))
+ (when (eq default p) (setf default-pos (point)))
+ (slime-insert-propertized
+ (list 'slime-connection p)
+ (format fstring
+ (if (eq default p) "*" " ")
+ (slime-connection-number p)
+ (slime-connection-name p)
+ (or (process-id p) (process-contact p))
+ (slime-pid p)
+ (slime-lisp-implementation-type p))))
+ (when default-pos
+ (goto-char default-pos))))
+
+
+;;;; Inspector
+
+(defgroup slime-inspector nil
+ "Inspector faces."
+ :prefix "slime-inspector-"
+ :group 'slime)
+
+(defface slime-inspector-topline-face
+ '((t ()))
+ "Face for top line describing object."
+ :group 'slime-inspector)
+
+(defface slime-inspector-label-face
+ '((t (:inherit font-lock-constant-face)))
+ "Face for labels in the inspector."
+ :group 'slime-inspector)
+
+(defface slime-inspector-value-face
+ '((t (:inherit font-lock-builtin-face)))
+ "Face for things which can themselves be inspected."
+ :group 'slime-inspector)
+
+(defface slime-inspector-action-face
+ '((t (:inherit font-lock-warning-face)))
+ "Face for labels of inspector actions."
+ :group 'slime-inspector)
+
+(defface slime-inspector-type-face
+ '((t (:inherit font-lock-type-face)))
+ "Face for type description in inspector."
+ :group 'slime-inspector)
+
+(defvar slime-inspector-mark-stack '())
+
+(defun slime-inspect (string)
+ "Eval an expression and inspect the result."
+ (interactive
+ (list (slime-read-from-minibuffer "Inspect value (evaluated): "
+ (slime-sexp-at-point))))
+ (slime-eval-async `(swank:init-inspector ,string) 'slime-open-inspector))
+
+(define-derived-mode slime-inspector-mode fundamental-mode
+ "Slime-Inspector"
+ "
+\\{slime-inspector-mode-map}
+\\{slime-popup-buffer-mode-map}"
+ (set-syntax-table lisp-mode-syntax-table)
+ (slime-set-truncate-lines)
+ (setq buffer-read-only t))
+
+(defun slime-inspector-buffer ()
+ (or (get-buffer (slime-buffer-name :inspector))
+ (slime-with-popup-buffer ((slime-buffer-name :inspector)
+ :mode 'slime-inspector-mode)
+ (setq slime-inspector-mark-stack '())
+ (buffer-disable-undo)
+ (current-buffer))))
+
+(defmacro slime-inspector-fontify (face string)
+ `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) ,string))
+
+(defvar slime-inspector-insert-ispec-function 'slime-inspector-insert-ispec)
+
+(defun slime-open-inspector (inspected-parts &optional point hook)
+ "Display INSPECTED-PARTS in a new inspector window.
+Optionally set point to POINT. If HOOK is provided, it is added to local
+KILL-BUFFER hooks for the inspector buffer."
+ (with-current-buffer (slime-inspector-buffer)
+ (when hook
+ (add-hook 'kill-buffer-hook hook t t))
+ (setq slime-buffer-connection (slime-current-connection))
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (pop-to-buffer (current-buffer))
+ (cl-destructuring-bind (&key id title content) inspected-parts
+ (cl-macrolet ((fontify (face string)
+ `(slime-inspector-fontify ,face ,string)))
+ (slime-propertize-region
+ (list 'slime-part-number id
+ 'mouse-face 'highlight
+ 'face 'slime-inspector-value-face)
+ (insert title))
+ (while (eq (char-before) ?\n)
+ (backward-delete-char 1))
+ (insert "\n" (fontify label "--------------------") "\n")
+ (save-excursion
+ (slime-inspector-insert-content content))
+ (when point
+ (cl-check-type point cons)
+ (ignore-errors
+ (goto-char (point-min))
+ (forward-line (1- (car point)))
+ (move-to-column (cdr point)))))))))
+
+(defvar slime-inspector-limit 500)
+
+(defun slime-inspector-insert-content (content)
+ (slime-inspector-fetch-chunk
+ content nil
+ (lambda (chunk)
+ (let ((inhibit-read-only t))
+ (slime-inspector-insert-chunk chunk t t)))))
+
+(defun slime-inspector-insert-chunk (chunk prev next)
+ "Insert CHUNK at point.
+If PREV resp. NEXT are true insert more-buttons as needed."
+ (cl-destructuring-bind (ispecs len start end) chunk
+ (when (and prev (> start 0))
+ (slime-inspector-insert-more-button start t))
+ (mapc slime-inspector-insert-ispec-function ispecs)
+ (when (and next (< end len))
+ (slime-inspector-insert-more-button end nil))))
+
+(defun slime-inspector-insert-ispec (ispec)
+ (if (stringp ispec)
+ (insert ispec)
+ (slime-dcase ispec
+ ((:value string id)
+ (slime-propertize-region
+ (list 'slime-part-number id
+ 'mouse-face 'highlight
+ 'face 'slime-inspector-value-face)
+ (insert string)))
+ ((:label string)
+ (insert (slime-inspector-fontify label string)))
+ ((:action string id)
+ (slime-insert-propertized (list 'slime-action-number id
+ 'mouse-face 'highlight
+ 'face 'slime-inspector-action-face)
+ string)))))
+
+(defun slime-inspector-position ()
+ "Return a pair (Y-POSITION X-POSITION) representing the
+position of point in the current buffer."
+ ;; We make sure we return absolute coordinates even if the user has
+ ;; narrowed the buffer.
+ ;; FIXME: why would somebody narrow the buffer?
+ (save-restriction
+ (widen)
+ (cons (line-number-at-pos)
+ (current-column))))
+
+(defun slime-inspector-property-at-point ()
+ (let* ((properties '(slime-part-number slime-range-button
+ slime-action-number))
+ (find-property
+ (lambda (point)
+ (cl-loop for property in properties
+ for value = (get-text-property point property)
+ when value
+ return (list property value)))))
+ (or (funcall find-property (point))
+ (funcall find-property (1- (point))))))
+
+(defun slime-inspector-operate-on-point ()
+ "Invoke the command for the text at point.
+1. If point is on a value then recursivly call the inspector on
+that value.
+2. If point is on an action then call that action.
+3. If point is on a range-button fetch and insert the range."
+ (interactive)
+ (let ((opener (lexical-let ((point (slime-inspector-position)))
+ (lambda (parts)
+ (when parts
+ (slime-open-inspector parts point)))))
+ (new-opener (lambda (parts)
+ (when parts
+ (slime-open-inspector parts)))))
+ (cl-destructuring-bind (&optional property value)
+ (slime-inspector-property-at-point)
+ (cl-case property
+ (slime-part-number
+ (slime-eval-async `(swank:inspect-nth-part ,value)
+ new-opener)
+ (push (slime-inspector-position) slime-inspector-mark-stack))
+ (slime-range-button
+ (slime-inspector-fetch-more value))
+ (slime-action-number
+ (slime-eval-async `(swank::inspector-call-nth-action ,value)
+ opener))
+ (t (error "No object at point"))))))
+
+(defun slime-inspector-operate-on-click (event)
+ "Move to events' position and operate the part."
+ (interactive "@e")
+ (let ((point (posn-point (event-end event))))
+ (cond ((and point
+ (or (get-text-property point 'slime-part-number)
+ (get-text-property point 'slime-range-button)
+ (get-text-property point 'slime-action-number)))
+ (goto-char point)
+ (slime-inspector-operate-on-point))
+ (t
+ (error "No clickable part here")))))
+
+(defun slime-inspector-pop ()
+ "Reinspect the previous object."
+ (interactive)
+ (slime-eval-async
+ `(swank:inspector-pop)
+ (lambda (result)
+ (cond (result
+ (slime-open-inspector result (pop slime-inspector-mark-stack)))
+ (t
+ (message "No previous object")
+ (ding))))))
+
+(defun slime-inspector-next ()
+ "Inspect the next object in the history."
+ (interactive)
+ (let ((result (slime-eval `(swank:inspector-next))))
+ (cond (result
+ (push (slime-inspector-position) slime-inspector-mark-stack)
+ (slime-open-inspector result))
+ (t (message "No next object")
+ (ding)))))
+
+(defun slime-inspector-quit ()
+ "Quit the inspector and kill the buffer."
+ (interactive)
+ (slime-eval-async `(swank:quit-inspector))
+ (quit-window t))
+
+;; FIXME: first return value is just point.
+;; FIXME: could probably use slime-search-property.
+(defun slime-find-inspectable-object (direction limit)
+ "Find the next/previous inspectable object.
+DIRECTION can be either 'next or 'prev.
+LIMIT is the maximum or minimum position in the current buffer.
+
+Return a list of two values: If an object could be found, the
+starting position of the found object and T is returned;
+otherwise LIMIT and NIL is returned."
+ (let ((finder (cl-ecase direction
+ (next 'next-single-property-change)
+ (prev 'previous-single-property-change))))
+ (let ((prop nil) (curpos (point)))
+ (while (and (not prop) (not (= curpos limit)))
+ (let ((newpos (funcall finder curpos 'slime-part-number nil limit)))
+ (setq prop (get-text-property newpos 'slime-part-number))
+ (setq curpos newpos)))
+ (list curpos (and prop t)))))
+
+(defun slime-inspector-next-inspectable-object (arg)
+ "Move point to the next inspectable object.
+With optional ARG, move across that many objects.
+If ARG is negative, move backwards."
+ (interactive "p")
+ (let ((maxpos (point-max)) (minpos (point-min))
+ (previously-wrapped-p nil))
+ ;; Forward.
+ (while (> arg 0)
+ (cl-destructuring-bind (pos foundp)
+ (slime-find-inspectable-object 'next maxpos)
+ (if foundp
+ (progn (goto-char pos) (setq arg (1- arg))
+ (setq previously-wrapped-p nil))
+ (if (not previously-wrapped-p) ; cycle detection
+ (progn (goto-char minpos) (setq previously-wrapped-p t))
+ (error "No inspectable objects")))))
+ ;; Backward.
+ (while (< arg 0)
+ (cl-destructuring-bind (pos foundp)
+ (slime-find-inspectable-object 'prev minpos)
+ ;; SLIME-OPEN-INSPECTOR inserts the title of an inspector page
+ ;; as a presentation at the beginning of the buffer; skip
+ ;; that. (Notice how this problem can not arise in ``Forward.'')
+ (if (and foundp (/= pos minpos))
+ (progn (goto-char pos) (setq arg (1+ arg))
+ (setq previously-wrapped-p nil))
+ (if (not previously-wrapped-p) ; cycle detection
+ (progn (goto-char maxpos) (setq previously-wrapped-p t))
+ (error "No inspectable objects")))))))
+
+(defun slime-inspector-previous-inspectable-object (arg)
+ "Move point to the previous inspectable object.
+With optional ARG, move across that many objects.
+If ARG is negative, move forwards."
+ (interactive "p")
+ (slime-inspector-next-inspectable-object (- arg)))
+
+(defun slime-inspector-describe ()
+ (interactive)
+ (slime-eval-describe `(swank:describe-inspectee)))
+
+(defun slime-inspector-pprint (part)
+ (interactive (list (or (get-text-property (point) 'slime-part-number)
+ (error "No part at point"))))
+ (slime-eval-describe `(swank:pprint-inspector-part ,part)))
+
+(defun slime-inspector-eval (string)
+ "Eval an expression in the context of the inspected object."
+ (interactive (list (slime-read-from-minibuffer "Inspector eval: ")))
+ (slime-eval-with-transcript `(swank:inspector-eval ,string)))
+
+(defun slime-inspector-history ()
+ "Show the previously inspected objects."
+ (interactive)
+ (slime-eval-describe `(swank:inspector-history)))
+
+(defun slime-inspector-show-source (part)
+ (interactive (list (or (get-text-property (point) 'slime-part-number)
+ (error "No part at point"))))
+ (slime-eval-async
+ `(swank:find-source-location-for-emacs '(:inspector ,part))
+ #'slime-show-source-location))
+
+(defun slime-inspector-reinspect ()
+ (interactive)
+ (slime-eval-async `(swank:inspector-reinspect)
+ (lexical-let ((point (slime-inspector-position)))
+ (lambda (parts)
+ (slime-open-inspector parts point)))))
+
+(defun slime-inspector-toggle-verbose ()
+ (interactive)
+ (slime-eval-async `(swank:inspector-toggle-verbose)
+ (lexical-let ((point (slime-inspector-position)))
+ (lambda (parts)
+ (slime-open-inspector parts point)))))
+
+(defun slime-inspector-insert-more-button (index previous)
+ (slime-insert-propertized
+ (list 'slime-range-button (list index previous)
+ 'mouse-face 'highlight
+ 'face 'slime-inspector-action-face)
+ (if previous " [--more--]\n" " [--more--]")))
+
+(defun slime-inspector-fetch-all ()
+ "Fetch all inspector contents and go to the end."
+ (interactive)
+ (goto-char (1- (point-max)))
+ (let ((button (get-text-property (point) 'slime-range-button)))
+ (when button
+ (let (slime-inspector-limit)
+ (slime-inspector-fetch-more button)))))
+
+(defun slime-inspector-fetch-more (button)
+ (cl-destructuring-bind (index prev) button
+ (slime-inspector-fetch-chunk
+ (list '() (1+ index) index index) prev
+ (slime-rcurry
+ (lambda (chunk prev)
+ (let ((inhibit-read-only t))
+ (apply #'delete-region (slime-property-bounds 'slime-range-button))
+ (slime-inspector-insert-chunk chunk prev (not prev))))
+ prev))))
+
+(defun slime-inspector-fetch-chunk (chunk prev cont)
+ (slime-inspector-fetch chunk slime-inspector-limit prev cont))
+
+(defun slime-inspector-fetch (chunk limit prev cont)
+ (cl-destructuring-bind (from to)
+ (slime-inspector-next-range chunk limit prev)
+ (cond ((and from to)
+ (slime-eval-async
+ `(swank:inspector-range ,from ,to)
+ (slime-rcurry (lambda (chunk2 chunk1 limit prev cont)
+ (slime-inspector-fetch
+ (slime-inspector-join-chunks chunk1 chunk2)
+ limit prev cont))
+ chunk limit prev cont)))
+ (t (funcall cont chunk)))))
+
+(defun slime-inspector-next-range (chunk limit prev)
+ (cl-destructuring-bind (_ len start end) chunk
+ (let ((count (- end start)))
+ (cond ((and prev (< 0 start) (or (not limit) (< count limit)))
+ (list (if limit (max (- end limit) 0) 0) start))
+ ((and (not prev) (< end len) (or (not limit) (< count limit)))
+ (list end (if limit (+ start limit) most-positive-fixnum)))
+ (t '(nil nil))))))
+
+(defun slime-inspector-join-chunks (chunk1 chunk2)
+ (cl-destructuring-bind (i1 _l1 s1 e1) chunk1
+ (cl-destructuring-bind (i2 l2 s2 e2) chunk2
+ (cond ((= e1 s2)
+ (list (append i1 i2) l2 s1 e2))
+ ((= e2 s1)
+ (list (append i2 i1) l2 s2 e1))
+ (t (error "Invalid chunks"))))))
+
+(set-keymap-parent slime-inspector-mode-map slime-parent-map)
+
+(slime-define-keys slime-inspector-mode-map
+ ([return] 'slime-inspector-operate-on-point)
+ ("\C-m" 'slime-inspector-operate-on-point)
+ ([mouse-1] 'slime-inspector-operate-on-click)
+ ([mouse-2] 'slime-inspector-operate-on-click)
+ ([mouse-6] 'slime-inspector-pop)
+ ([mouse-7] 'slime-inspector-next)
+ ("l" 'slime-inspector-pop)
+ ("n" 'slime-inspector-next)
+ (" " 'slime-inspector-next)
+ ("d" 'slime-inspector-describe)
+ ("p" 'slime-inspector-pprint)
+ ("e" 'slime-inspector-eval)
+ ("h" 'slime-inspector-history)
+ ("g" 'slime-inspector-reinspect)
+ ("v" 'slime-inspector-toggle-verbose)
+ ("\C-i" 'slime-inspector-next-inspectable-object)
+ ([(shift tab)]
+ 'slime-inspector-previous-inspectable-object) ; Emacs translates S-TAB
+ ([backtab] 'slime-inspector-previous-inspectable-object) ; to BACKTAB on X.
+ ("." 'slime-inspector-show-source)
+ (">" 'slime-inspector-fetch-all)
+ ("q" 'slime-inspector-quit))
+
+
+;;;; Buffer selector
+
+(defvar slime-selector-methods nil
+ "List of buffer-selection methods for the `slime-select' command.
+Each element is a list (KEY DESCRIPTION FUNCTION).
+DESCRIPTION is a one-line description of what the key selects.")
+
+(defvar slime-selector-other-window nil
+ "If non-nil use switch-to-buffer-other-window.")
+
+(defun slime-selector (&optional other-window)
+ "Select a new buffer by type, indicated by a single character.
+The user is prompted for a single character indicating the method by
+which to choose a new buffer. The `?' character describes the
+available methods.
+
+See `def-slime-selector-method' for defining new methods."
+ (interactive)
+ (message "Select [%s]: "
+ (apply #'string (mapcar #'car slime-selector-methods)))
+ (let* ((slime-selector-other-window other-window)
+ (ch (save-window-excursion
+ (select-window (minibuffer-window))
+ (read-char)))
+ (method (cl-find ch slime-selector-methods :key #'car)))
+ (cond (method
+ (funcall (cl-third method)))
+ (t
+ (message "No method for character: ?\\%c" ch)
+ (ding)
+ (sleep-for 1)
+ (discard-input)
+ (slime-selector)))))
+
+(defmacro def-slime-selector-method (key description &rest body)
+ "Define a new `slime-select' buffer selection method.
+
+KEY is the key the user will enter to choose this method.
+
+DESCRIPTION is a one-line sentence describing how the method
+selects a buffer.
+
+BODY is a series of forms which are evaluated when the selector
+is chosen. The returned buffer is selected with
+switch-to-buffer."
+ (let ((method `(lambda ()
+ (let ((buffer (progn ,@body)))
+ (cond ((not (get-buffer buffer))
+ (message "No such buffer: %S" buffer)
+ (ding))
+ ((get-buffer-window buffer)
+ (select-window (get-buffer-window buffer)))
+ (slime-selector-other-window
+ (switch-to-buffer-other-window buffer))
+ (t
+ (switch-to-buffer buffer)))))))
+ `(setq slime-selector-methods
+ (cl-sort (cons (list ,key ,description ,method)
+ (cl-remove ,key slime-selector-methods :key #'car))
+ #'< :key #'car))))
+
+(def-slime-selector-method ?? "Selector help buffer."
+ (ignore-errors (kill-buffer "*Select Help*"))
+ (with-current-buffer (get-buffer-create "*Select Help*")
+ (insert "Select Methods:\n\n")
+ (cl-loop for (key line nil) in slime-selector-methods
+ do (insert (format "%c:\t%s\n" key line)))
+ (goto-char (point-min))
+ (help-mode)
+ (display-buffer (current-buffer) t))
+ (slime-selector)
+ (current-buffer))
+
+(cl-pushnew (list ?4 "Select in other window" (lambda () (slime-selector t)))
+ slime-selector-methods :key #'car)
+
+(def-slime-selector-method ?q "Abort."
+ (top-level))
+
+(def-slime-selector-method ?i
+ "*inferior-lisp* buffer."
+ (cond ((and (slime-connected-p) (slime-process))
+ (process-buffer (slime-process)))
+ (t
+ "*inferior-lisp*")))
+
+(def-slime-selector-method ?v
+ "*slime-events* buffer."
+ slime-event-buffer-name)
+
+(def-slime-selector-method ?l
+ "most recently visited lisp-mode buffer."
+ (slime-recently-visited-buffer 'lisp-mode))
+
+(def-slime-selector-method ?d
+ "*sldb* buffer for the current connection."
+ (or (sldb-get-default-buffer)
+ (error "No debugger buffer")))
+
+(def-slime-selector-method ?e
+ "most recently visited emacs-lisp-mode buffer."
+ (slime-recently-visited-buffer 'emacs-lisp-mode))
+
+(def-slime-selector-method ?c
+ "SLIME connections buffer."
+ (slime-list-connections)
+ slime-connections-buffer-name)
+
+(def-slime-selector-method ?n
+ "Cycle to the next Lisp connection."
+ (slime-next-connection)
+ (concat "*slime-repl "
+ (slime-connection-name (slime-current-connection))
+ "*"))
+
+(def-slime-selector-method ?p
+ "Cycle to the previous Lisp connection."
+ (slime-prev-connection)
+ (concat "*slime-repl "
+ (slime-connection-name (slime-current-connection))
+ "*"))
+
+(def-slime-selector-method ?t
+ "SLIME threads buffer."
+ (slime-list-threads)
+ slime-threads-buffer-name)
+
+(defun slime-recently-visited-buffer (mode)
+ "Return the most recently visited buffer whose major-mode is MODE.
+Only considers buffers that are not already visible."
+ (cl-loop for buffer in (buffer-list)
+ when (and (with-current-buffer buffer (eq major-mode mode))
+ (not (string-match "^ " (buffer-name buffer)))
+ (null (get-buffer-window buffer 'visible)))
+ return buffer
+ finally (error "Can't find unshown buffer in %S" mode)))
+
+
+;;;; Indentation
+
+(defun slime-update-indentation ()
+ "Update indentation for all macros defined in the Lisp system."
+ (interactive)
+ (slime-eval-async '(swank:update-indentation-information)))
+
+(defvar slime-indentation-update-hooks)
+
+(defun slime-intern-indentation-spec (spec)
+ (cond ((consp spec)
+ (cons (slime-intern-indentation-spec (car spec))
+ (slime-intern-indentation-spec (cdr spec))))
+ ((stringp spec)
+ (intern spec))
+ (t
+ spec)))
+
+;; FIXME: restore the old version without per-package
+;; stuff. slime-indentation.el should be able tho disable the simple
+;; version if needed.
+(defun slime-handle-indentation-update (alist)
+ "Update Lisp indent information.
+
+ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation
+settings for `common-lisp-indent-function'. The appropriate property
+is setup, unless the user already set one explicitly."
+ (dolist (info alist)
+ (let ((symbol (intern (car info)))
+ (indent (slime-intern-indentation-spec (cl-second info)))
+ (packages (cl-third info)))
+ (if (and (boundp 'common-lisp-system-indentation)
+ (fboundp 'slime-update-system-indentation))
+ ;; A table provided by slime-cl-indent.el.
+ (funcall #'slime-update-system-indentation symbol indent packages)
+ ;; Does the symbol have an indentation value that we set?
+ (when (equal (get symbol 'common-lisp-indent-function)
+ (get symbol 'slime-indent))
+ (put symbol 'common-lisp-indent-function indent)
+ (put symbol 'slime-indent indent)))
+ (run-hook-with-args 'slime-indentation-update-hooks
+ symbol indent packages))))
+
+
+;;;; Contrib modules
+
+(defun slime-require (module)
+ (cl-pushnew module slime-required-modules)
+ (when (slime-connected-p)
+ (slime-load-contribs)))
+
+(defun slime-load-contribs ()
+ (let ((needed (cl-remove-if (lambda (s)
+ (member (cl-subseq (symbol-name s) 1)
+ (mapcar #'downcase
+ (slime-lisp-modules))))
+ slime-required-modules)))
+ (when needed
+ ;; No asynchronous request because with :SPAWN that could result
+ ;; in the attempt to load modules concurrently which may not be
+ ;; supported by the host Lisp.
+ (setf (slime-lisp-modules)
+ (slime-eval `(swank:swank-require ',needed))))))
+
+(cl-defstruct slime-contrib
+ name
+ slime-dependencies
+ swank-dependencies
+ enable
+ disable
+ authors
+ license)
+
+(defun slime-contrib--enable-fun (name)
+ (intern (concat (symbol-name name) "-init")))
+
+(defun slime-contrib--disable-fun (name)
+ (intern (concat (symbol-name name) "-unload")))
+
+(defmacro define-slime-contrib (name _docstring &rest clauses)
+ (declare (indent 1))
+ (cl-destructuring-bind (&key slime-dependencies
+ swank-dependencies
+ on-load
+ on-unload
+ authors
+ license)
+ (cl-loop for (key . value) in clauses append `(,key ,value))
+ `(progn
+ ,@(mapcar (lambda (d) `(require ',d)) slime-dependencies)
+ (defun ,(slime-contrib--enable-fun name) ()
+ (mapc #'funcall ',(mapcar
+ #'slime-contrib--enable-fun
+ slime-dependencies))
+ (mapc #'slime-require ',swank-dependencies)
+ ,@on-load)
+ (defun ,(slime-contrib--disable-fun name) ()
+ ,@on-unload
+ (mapc #'funcall ',(mapcar
+ #'slime-contrib--disable-fun
+ slime-dependencies)))
+ (put 'slime-contribs ',name
+ (make-slime-contrib
+ :name ',name :authors ',authors :license ',license
+ :slime-dependencies ',slime-dependencies
+ :swank-dependencies ',swank-dependencies
+ :enable ',(slime-contrib--enable-fun name)
+ :disable ',(slime-contrib--disable-fun name))))))
+
+(defun slime-all-contribs ()
+ (cl-loop for (nil val) on (symbol-plist 'slime-contribs) by #'cddr
+ when (slime-contrib-p val)
+ collect val))
+
+(defun slime-contrib-all-dependencies (contrib)
+ "List all contribs recursively needed by CONTRIB, including self."
+ (cons contrib
+ (cl-mapcan #'slime-contrib-all-dependencies
+ (slime-contrib-slime-dependencies
+ (slime-find-contrib contrib)))))
+
+(defun slime-find-contrib (name)
+ (get 'slime-contribs name))
+
+(defun slime-read-contrib-name ()
+ (let ((names (cl-loop for c in (slime-all-contribs) collect
+ (symbol-name (slime-contrib-name c)))))
+ (intern (completing-read "Contrib: " names nil t))))
+
+(defun slime-enable-contrib (name)
+ (interactive (list (slime-read-contrib-name)))
+ (let ((c (or (slime-find-contrib name)
+ (error "Unknown contrib: %S" name))))
+ (funcall (slime-contrib-enable c))))
+
+(defun slime-disable-contrib (name)
+ (interactive (list (slime-read-contrib-name)))
+ (let ((c (or (slime-find-contrib name)
+ (error "Unknown contrib: %S" name))))
+ (funcall (slime-contrib-disable c))))
+
+
+;;;;; Pull-down menu
+
+(defvar slime-easy-menu
+ (let ((C '(slime-connected-p)))
+ `("SLIME"
+ [ "Edit Definition..." slime-edit-definition ,C ]
+ [ "Return From Definition" slime-pop-find-definition-stack ,C ]
+ [ "Complete Symbol" completion-at-point ,C ]
+ "--"
+ ("Evaluation"
+ [ "Eval Defun" slime-eval-defun ,C ]
+ [ "Eval Last Expression" slime-eval-last-expression ,C ]
+ [ "Eval And Pretty-Print" slime-pprint-eval-last-expression ,C ]
+ [ "Eval Region" slime-eval-region ,C ]
+ [ "Eval Region And Pretty-Print" slime-pprint-eval-region ,C ]
+ [ "Interactive Eval..." slime-interactive-eval ,C ]
+ [ "Edit Lisp Value..." slime-edit-value ,C ]
+ [ "Call Defun" slime-call-defun ,C ])
+ ("Debugging"
+ [ "Macroexpand Once..." slime-macroexpand-1 ,C ]
+ [ "Macroexpand All..." slime-macroexpand-all ,C ]
+ [ "Create Trace Buffer" slime-redirect-trace-output ,C ]
+ [ "Toggle Trace..." slime-toggle-trace-fdefinition ,C ]
+ [ "Untrace All" slime-untrace-all ,C]
+ [ "Disassemble..." slime-disassemble-symbol ,C ]
+ [ "Inspect..." slime-inspect ,C ])
+ ("Compilation"
+ [ "Compile Defun" slime-compile-defun ,C ]
+ [ "Compile/Load File" slime-compile-and-load-file ,C ]
+ [ "Compile File" slime-compile-file ,C ]
+ [ "Compile Region" slime-compile-region ,C ]
+ "--"
+ [ "Next Note" slime-next-note t ]
+ [ "Previous Note" slime-previous-note t ]
+ [ "Remove Notes" slime-remove-notes t ]
+ [ "List Notes" slime-list-compiler-notes ,C ])
+ ("Cross Reference"
+ [ "Who Calls..." slime-who-calls ,C ]
+ [ "Who References... " slime-who-references ,C ]
+ [ "Who Sets..." slime-who-sets ,C ]
+ [ "Who Binds..." slime-who-binds ,C ]
+ [ "Who Macroexpands..." slime-who-macroexpands ,C ]
+ [ "Who Specializes..." slime-who-specializes ,C ]
+ [ "List Callers..." slime-list-callers ,C ]
+ [ "List Callees..." slime-list-callees ,C ]
+ [ "Next Location" slime-next-location t ])
+ ("Editing"
+ [ "Check Parens" check-parens t]
+ [ "Update Indentation" slime-update-indentation ,C]
+ [ "Select Buffer" slime-selector t])
+ ("Profiling"
+ [ "Toggle Profiling..." slime-toggle-profile-fdefinition ,C ]
+ [ "Profile Package" slime-profile-package ,C]
+ [ "Profile by Substring" slime-profile-by-substring ,C ]
+ [ "Unprofile All" slime-unprofile-all ,C ]
+ [ "Show Profiled" slime-profiled-functions ,C ]
+ "--"
+ [ "Report" slime-profile-report ,C ]
+ [ "Reset Counters" slime-profile-reset ,C ])
+ ("Documentation"
+ [ "Describe Symbol..." slime-describe-symbol ,C ]
+ [ "Lookup Documentation..." slime-documentation-lookup t ]
+ [ "Apropos..." slime-apropos ,C ]
+ [ "Apropos all..." slime-apropos-all ,C ]
+ [ "Apropos Package..." slime-apropos-package ,C ]
+ [ "Hyperspec..." slime-hyperspec-lookup t ])
+ "--"
+ [ "Interrupt Command" slime-interrupt ,C ]
+ [ "Abort Async. Command" slime-quit ,C ]
+ [ "Sync Package & Directory" slime-sync-package-and-default-directory ,C]
+ )))
+
+(defvar slime-sldb-easy-menu
+ (let ((C '(slime-connected-p)))
+ `("SLDB"
+ [ "Next Frame" sldb-down t ]
+ [ "Previous Frame" sldb-up t ]
+ [ "Toggle Frame Details" sldb-toggle-details t ]
+ [ "Next Frame (Details)" sldb-details-down t ]
+ [ "Previous Frame (Details)" sldb-details-up t ]
+ "--"
+ [ "Eval Expression..." slime-interactive-eval ,C ]
+ [ "Eval in Frame..." sldb-eval-in-frame ,C ]
+ [ "Eval in Frame (pretty print)..." sldb-pprint-eval-in-frame ,C ]
+ [ "Inspect In Frame..." sldb-inspect-in-frame ,C ]
+ [ "Inspect Condition Object" sldb-inspect-condition ,C ]
+ "--"
+ [ "Restart Frame" sldb-restart-frame ,C ]
+ [ "Return from Frame..." sldb-return-from-frame ,C ]
+ ("Invoke Restart"
+ [ "Continue" sldb-continue ,C ]
+ [ "Abort" sldb-abort ,C ]
+ [ "Step" sldb-step ,C ]
+ [ "Step next" sldb-next ,C ]
+ [ "Step out" sldb-out ,C ]
+ )
+ "--"
+ [ "Quit (throw)" sldb-quit ,C ]
+ [ "Break With Default Debugger" sldb-break-with-default-debugger ,C ])))
+
+(easy-menu-define menubar-slime slime-mode-map "SLIME" slime-easy-menu)
+
+(defun slime-add-easy-menu ()
+ (easy-menu-add slime-easy-menu 'slime-mode-map))
+
+(add-hook 'slime-mode-hook 'slime-add-easy-menu)
+
+(defun slime-sldb-add-easy-menu ()
+ (easy-menu-define menubar-slime-sldb
+ sldb-mode-map "SLDB" slime-sldb-easy-menu)
+ (easy-menu-add slime-sldb-easy-menu 'sldb-mode-map))
+
+(add-hook 'sldb-mode-hook 'slime-sldb-add-easy-menu)
+
+
+;;;; Cheat Sheet
+
+(defvar
+ slime-cheat-sheet-table
+ '((:title
+ "Editing lisp code"
+ :map slime-mode-map
+ :bindings ((slime-eval-defun "Evaluate current top level form")
+ (slime-compile-defun "Compile current top level form")
+ (slime-interactive-eval "Prompt for form and eval it")
+ (slime-compile-and-load-file "Compile and load current file")
+ (slime-sync-package-and-default-directory
+ "Synch default package and directory with current buffer")
+ (slime-next-note "Next compiler note")
+ (slime-previous-note "Previous compiler note")
+ (slime-remove-notes "Remove notes")
+ slime-documentation-lookup))
+ (:title "Completion"
+ :map slime-mode-map
+ :bindings (slime-indent-and-complete-symbol
+ slime-fuzzy-complete-symbol))
+ (:title
+ "Within SLDB buffers"
+ :map sldb-mode-map
+ :bindings ((sldb-default-action "Do 'whatever' with thing at point")
+ (sldb-toggle-details "Toggle frame details visualization")
+ (sldb-quit "Quit to REPL")
+ (sldb-abort "Invoke ABORT restart")
+ (sldb-continue "Invoke CONTINUE restart (if available)")
+ (sldb-show-source "Jump to frame's source code")
+ (sldb-eval-in-frame "Evaluate in frame at point")
+ (sldb-inspect-in-frame
+ "Evaluate in frame at point and inspect result")))
+ (:title
+ "Within the Inspector"
+ :map slime-inspector-mode-map
+ :bindings ((slime-inspector-next-inspectable-object
+ "Jump to next inspectable object")
+ (slime-inspector-operate-on-point
+ "Inspect object or execute action at point")
+ (slime-inspector-reinspect "Reinspect current object")
+ (slime-inspector-pop "Return to previous object")
+ ;;(slime-inspector-copy-down "Send object at point to REPL")
+ (slime-inspector-toggle-verbose "Toggle verbose mode")
+ (slime-inspector-quit "Quit")))
+ (:title
+ "Finding Definitions"
+ :map slime-mode-map
+ :bindings (slime-edit-definition
+ slime-pop-find-definition-stack))))
+
+(defun slime-cheat-sheet ()
+ (interactive)
+ (switch-to-buffer-other-frame
+ (get-buffer-create (slime-buffer-name :cheat-sheet)))
+ (setq buffer-read-only nil)
+ (delete-region (point-min) (point-max))
+ (goto-char (point-min))
+ (insert
+ "SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode).\n\n")
+ (dolist (mode slime-cheat-sheet-table)
+ (let ((title (cl-getf mode :title))
+ (mode-map (cl-getf mode :map))
+ (mode-keys (cl-getf mode :bindings)))
+ (insert title)
+ (insert ":\n")
+ (insert (make-string (1+ (length title)) ?-))
+ (insert "\n")
+ (let ((keys '())
+ (descriptions '()))
+ (dolist (func mode-keys)
+ ;; func is eithor the function name or a list (NAME DESCRIPTION)
+ (push (if (symbolp func)
+ (prin1-to-string func)
+ (cl-second func))
+ descriptions)
+ (let ((all-bindings (where-is-internal (if (symbolp func)
+ func
+ (cl-first func))
+ (symbol-value mode-map)))
+ (key-bindings '()))
+ (dolist (binding all-bindings)
+ (when (and (vectorp binding)
+ (integerp (aref binding 0)))
+ (push binding key-bindings)))
+ (push (mapconcat 'key-description key-bindings " or ") keys)))
+ (cl-loop with desc-length = (apply 'max (mapcar 'length descriptions))
+ for key in (nreverse keys)
+ for desc in (nreverse descriptions)
+ do (insert desc)
+ do (insert (make-string (- desc-length (length desc)) ? ))
+ do (insert " => ")
+ do (insert (if (string= "" key)
+ "<not on any key>"
+ key))
+ do (insert "\n")
+ finally do (insert "\n")))))
+ (setq buffer-read-only t)
+ (goto-char (point-min)))
+
+
+;;;; Utilities (no not Paul Graham style)
+
+;; XXX: unused function
+(defun slime-intersperse (element list)
+ "Intersperse ELEMENT between each element of LIST."
+ (if (null list)
+ '()
+ (cons (car list)
+ (cl-mapcan (lambda (x) (list element x)) (cdr list)))))
+
+;;; FIXME: this looks almost slime `slime-alistify', perhaps the two
+;;; functions can be merged.
+(defun slime-group-similar (similar-p list)
+ "Return the list of lists of 'similar' adjacent elements of LIST.
+The function SIMILAR-P is used to test for similarity.
+The order of the input list is preserved."
+ (if (null list)
+ nil
+ (let ((accumulator (list (list (car list)))))
+ (dolist (x (cdr list))
+ (if (funcall similar-p x (caar accumulator))
+ (push x (car accumulator))
+ (push (list x) accumulator)))
+ (reverse (mapcar #'reverse accumulator)))))
+
+(defun slime-alistify (list key test)
+ "Partition the elements of LIST into an alist.
+KEY extracts the key from an element and TEST is used to compare
+keys."
+ (let ((alist '()))
+ (dolist (e list)
+ (let* ((k (funcall key e))
+ (probe (cl-assoc k alist :test test)))
+ (if probe
+ (push e (cdr probe))
+ (push (cons k (list e)) alist))))
+ ;; Put them back in order.
+ (cl-loop for (key . value) in (reverse alist)
+ collect (cons key (reverse value)))))
+
+;;;;; Misc.
+
+(defun slime-length= (seq n)
+ "Return (= (length SEQ) N)."
+ (cl-etypecase seq
+ (list
+ (cond ((zerop n) (null seq))
+ ((let ((tail (nthcdr (1- n) seq)))
+ (and tail (null (cdr tail)))))))
+ (sequence
+ (= (length seq) n))))
+
+(defun slime-length> (seq n)
+ "Return (> (length SEQ) N)."
+ (cl-etypecase seq
+ (list (nthcdr n seq))
+ (sequence (> (length seq) n))))
+
+(defun slime-trim-whitespace (str)
+ (let ((start (cl-position-if-not (lambda (x)
+ (memq x '(?\t ?\n ?\s ?\r)))
+ str))
+
+ (end (cl-position-if-not (lambda (x)
+ (memq x '(?\t ?\n ?\s ?\r)))
+ str
+ :from-end t)))
+ (if start
+ (substring str start (1+ end))
+ "")))
+
+;;;;; Buffer related
+
+(defun slime-buffer-narrowed-p (&optional buffer)
+ "Returns T if BUFFER (or the current buffer respectively) is narrowed."
+ (with-current-buffer (or buffer (current-buffer))
+ (let ((beg (point-min))
+ (end (point-max))
+ (total (buffer-size)))
+ (or (/= beg 1) (/= end (1+ total))))))
+
+(defun slime-column-max ()
+ (save-excursion
+ (goto-char (point-min))
+ (cl-loop for column = (prog2 (end-of-line) (current-column) (forward-line))
+ until (= (point) (point-max))
+ maximizing column)))
+
+;;;;; CL symbols vs. Elisp symbols.
+
+(defun slime-cl-symbol-name (symbol)
+ (let ((n (if (stringp symbol) symbol (symbol-name symbol))))
+ (if (string-match ":\\([^:]*\\)$" n)
+ (let ((symbol-part (match-string 1 n)))
+ (if (string-match "^|\\(.*\\)|$" symbol-part)
+ (match-string 1 symbol-part)
+ symbol-part))
+ n)))
+
+(defun slime-cl-symbol-package (symbol &optional default)
+ (let ((n (if (stringp symbol) symbol (symbol-name symbol))))
+ (if (string-match "^\\([^:]*\\):" n)
+ (match-string 1 n)
+ default)))
+
+(defun slime-qualify-cl-symbol-name (symbol-or-name)
+ "Return a package-qualified string for SYMBOL-OR-NAME.
+If SYMBOL-OR-NAME doesn't already have a package prefix the
+current package is used."
+ (let ((s (if (stringp symbol-or-name)
+ symbol-or-name
+ (symbol-name symbol-or-name))))
+ (if (slime-cl-symbol-package s)
+ s
+ (format "%s::%s"
+ (let* ((package (slime-current-package)))
+ ;; package is a string like ":cl-user"
+ ;; or "CL-USER", or "\"CL-USER\"".
+ (if package
+ (slime-pretty-package-name package)
+ "CL-USER"))
+ (slime-cl-symbol-name s)))))
+
+;;;;; Moving, CL idiosyncracies aware (reader conditionals &c.)
+
+(defmacro slime-point-moves-p (&rest body)
+ "Execute BODY and return true if the current buffer's point moved."
+ (declare (indent 0))
+ (let ((pointvar (cl-gensym "point-")))
+ `(let ((,pointvar (point)))
+ (save-current-buffer ,@body)
+ (/= ,pointvar (point)))))
+
+(defun slime-forward-sexp (&optional count)
+ "Like `forward-sexp', but understands reader-conditionals (#- and #+),
+and skips comments."
+ (dotimes (_i (or count 1))
+ (slime-forward-cruft)
+ (forward-sexp)))
+
+(defconst slime-reader-conditionals-regexp
+ ;; #!+, #!- are SBCL specific reader-conditional syntax.
+ ;; We need this for the source files of SBCL itself.
+ (regexp-opt '("#+" "#-" "#!+" "#!-")))
+
+(defun slime-forward-reader-conditional ()
+ "Move past any reader conditional (#+ or #-) at point."
+ (when (looking-at slime-reader-conditionals-regexp)
+ (goto-char (match-end 0))
+ (let* ((plus-conditional-p (eq (char-before) ?+))
+ (result (slime-eval-feature-expression
+ (condition-case e
+ (read (current-buffer))
+ (invalid-read-syntax
+ (signal 'slime-unknown-feature-expression (cdr e)))))))
+ (unless (if plus-conditional-p result (not result))
+ ;; skip this sexp
+ (slime-forward-sexp)))))
+
+(defun slime-forward-cruft ()
+ "Move forward over whitespace, comments, reader conditionals."
+ (while (slime-point-moves-p (skip-chars-forward " \t\n")
+ (forward-comment (buffer-size))
+ (inline (slime-forward-reader-conditional)))))
+
+(defun slime-keywordify (symbol)
+ "Make a keyword out of the symbol SYMBOL."
+ (let ((name (downcase (symbol-name symbol))))
+ (intern (if (eq ?: (aref name 0))
+ name
+ (concat ":" name)))))
+
+(put 'slime-incorrect-feature-expression
+ 'error-conditions '(slime-incorrect-feature-expression error))
+
+(put 'slime-unknown-feature-expression
+ 'error-conditions '(slime-unknown-feature-expression
+ slime-incorrect-feature-expression
+ error))
+
+;; FIXME: let it crash
+;; FIXME: the length=1 constraint is bogus
+(defun slime-eval-feature-expression (e)
+ "Interpret a reader conditional expression."
+ (cond ((symbolp e)
+ (memq (slime-keywordify e) (slime-lisp-features)))
+ ((and (consp e) (symbolp (car e)))
+ (funcall (let ((head (slime-keywordify (car e))))
+ (cl-case head
+ (:and #'cl-every)
+ (:or #'cl-some)
+ (:not
+ (lexical-let ((feature-expression e))
+ (lambda (f l)
+ (cond
+ ((slime-length= l 0) t)
+ ((slime-length= l 1) (not (apply f l)))
+ (t (signal 'slime-incorrect-feature-expression
+ feature-expression))))))
+ (t (signal 'slime-unknown-feature-expression head))))
+ #'slime-eval-feature-expression
+ (cdr e)))
+ (t (signal 'slime-incorrect-feature-expression e))))
+
+;;;;; Extracting Lisp forms from the buffer or user
+
+(defun slime-defun-at-point ()
+ "Return the text of the defun at point."
+ (apply #'buffer-substring-no-properties
+ (slime-region-for-defun-at-point)))
+
+(defun slime-region-for-defun-at-point ()
+ "Return the start and end position of defun at point."
+ (save-excursion
+ (save-match-data
+ (end-of-defun)
+ (let ((end (point)))
+ (beginning-of-defun)
+ (list (point) end)))))
+
+(defun slime-beginning-of-symbol ()
+ "Move to the beginning of the CL-style symbol at point."
+ (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\="
+ (when (> (point) 2000) (- (point) 2000))
+ t))
+ (re-search-forward "\\=#[-+.<|]" nil t)
+ (when (and (looking-at "@") (eq (char-before) ?\,))
+ (forward-char)))
+
+(defun slime-end-of-symbol ()
+ "Move to the end of the CL-style symbol at point."
+ (re-search-forward "\\=\\(\\sw\\|\\s_\\|\\s\\.\\|#:\\|[@|]\\)*"))
+
+(put 'slime-symbol 'end-op 'slime-end-of-symbol)
+(put 'slime-symbol 'beginning-op 'slime-beginning-of-symbol)
+
+(defun slime-symbol-start-pos ()
+ "Return the starting position of the symbol under point.
+The result is unspecified if there isn't a symbol under the point."
+ (save-excursion (slime-beginning-of-symbol) (point)))
+
+(defun slime-symbol-end-pos ()
+ (save-excursion (slime-end-of-symbol) (point)))
+
+(defun slime-bounds-of-symbol-at-point ()
+ "Return the bounds of the symbol around point.
+The returned bounds are either nil or non-empty."
+ (let ((bounds (bounds-of-thing-at-point 'slime-symbol)))
+ (if (and bounds
+ (< (car bounds)
+ (cdr bounds)))
+ bounds)))
+
+(defun slime-symbol-at-point ()
+ "Return the name of the symbol at point, otherwise nil."
+ ;; (thing-at-point 'symbol) returns "" in empty buffers
+ (let ((bounds (slime-bounds-of-symbol-at-point)))
+ (if bounds
+ (buffer-substring-no-properties (car bounds)
+ (cdr bounds)))))
+
+(defun slime-bounds-of-sexp-at-point ()
+ "Return the bounds sexp at point as a pair (or nil)."
+ (or (slime-bounds-of-symbol-at-point)
+ (and (equal (char-after) ?\()
+ (member (char-before) '(?\' ?\, ?\@))
+ ;; hide stuff before ( to avoid quirks with '( etc.
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (bounds-of-thing-at-point 'sexp)))
+ (bounds-of-thing-at-point 'sexp)))
+
+(defun slime-sexp-at-point ()
+ "Return the sexp at point as a string, otherwise nil."
+ (let ((bounds (slime-bounds-of-sexp-at-point)))
+ (if bounds
+ (buffer-substring-no-properties (car bounds)
+ (cdr bounds)))))
+
+(defun slime-sexp-at-point-or-error ()
+ "Return the sexp at point as a string, othwise signal an error."
+ (or (slime-sexp-at-point) (user-error "No expression at point")))
+
+(defun slime-string-at-point ()
+ "Returns the string at point as a string, otherwise nil."
+ (let ((sexp (slime-sexp-at-point)))
+ (if (and sexp
+ (eql (char-syntax (aref sexp 0)) ?\"))
+ sexp
+ nil)))
+
+(defun slime-string-at-point-or-error ()
+ "Return the sexp at point as a string, othwise signal an error."
+ (or (slime-string-at-point) (error "No string at point.")))
+
+(defun slime-input-complete-p (start end)
+ "Return t if the region from START to END contains a complete sexp."
+ (save-excursion
+ (goto-char start)
+ (cond ((looking-at "\\s *['`#]?[(\"]")
+ (ignore-errors
+ (save-restriction
+ (narrow-to-region start end)
+ ;; Keep stepping over blanks and sexps until the end of
+ ;; buffer is reached or an error occurs. Tolerate extra
+ ;; close parens.
+ (cl-loop do (skip-chars-forward " \t\r\n)")
+ until (eobp)
+ do (forward-sexp))
+ t)))
+ (t t))))
+
+
+;;;; slime.el in pretty colors
+
+(cl-loop for sym in (list 'slime-def-connection-var
+ 'slime-define-channel-type
+ 'slime-define-channel-method
+ 'define-slime-contrib
+ 'slime-defun-if-undefined
+ 'slime-defmacro-if-undefined)
+ for regexp = (format "(\\(%S\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"
+ sym)
+ do (font-lock-add-keywords
+ 'emacs-lisp-mode
+ `((,regexp (1 font-lock-keyword-face)
+ (2 font-lock-variable-name-face)))))
+
+;;;; Finishing up
+
+(eval-when-compile
+ (require 'bytecomp))
+
+(defun slime--byte-compile (symbol)
+ (require 'bytecomp) ;; tricky interaction between autoload and let.
+ (let ((byte-compile-warnings '()))
+ (byte-compile symbol)))
+
+(defun slime--compile-hotspots ()
+ (mapc (lambda (sym)
+ (cond ((fboundp sym)
+ (unless (byte-code-function-p (symbol-function sym))
+ (slime--byte-compile sym)))
+ (t (error "%S is not fbound" sym))))
+ '(slime-alistify
+ slime-log-event
+ slime-events-buffer
+ slime-process-available-input
+ slime-dispatch-event
+ slime-net-filter
+ slime-net-have-input-p
+ slime-net-decode-length
+ slime-net-read
+ slime-print-apropos
+ slime-insert-propertized
+ slime-beginning-of-symbol
+ slime-end-of-symbol
+ slime-eval-feature-expression
+ slime-forward-sexp
+ slime-forward-cruft
+ slime-forward-reader-conditional)))
+
+(slime--compile-hotspots)
+
+(add-to-list 'load-path (expand-file-name "contrib" slime-path))
+
+(run-hooks 'slime-load-hook)
+(provide 'slime)
+
+;; Local Variables:
+;; outline-regexp: ";;;;+"
+;; indent-tabs-mode: nil
+;; coding: latin-1-unix
+;; End:
+;;; slime.el ends here
diff --git a/vim/bundle/slimv/slime/start-swank.lisp b/vim/bundle/slimv/slime/start-swank.lisp
new file mode 100644
index 0000000..77bd3aa
--- /dev/null
+++ b/vim/bundle/slimv/slime/start-swank.lisp
@@ -0,0 +1,39 @@
+;;; This file is intended to be loaded by an implementation to
+;;; get a running swank server
+;;; e.g. sbcl --load start-swank.lisp
+;;;
+;;; Default port is 4005
+
+;;; For additional swank-side configurations see
+;;; 6.2 section of the Slime user manual.
+;;;
+;;; Modified for Slimv:
+;;; - don't close connection
+;;; - pass swank port in environment variable
+
+(load (merge-pathnames "swank-loader.lisp" *load-truename*))
+
+(swank-loader:init
+ :delete nil ; delete any existing SWANK packages
+ :reload nil ; reload SWANK, even if the SWANK package already exists
+ :load-contribs nil) ; load all contribs
+
+(defun my-getenv (name &optional default)
+ #+CMU
+ (let ((x (assoc name ext:*environment-list*
+ :test #'string=)))
+ (if x (cdr x) default))
+ #-CMU
+ (or
+ #+Allegro (sys:getenv name)
+ #+CLISP (ext:getenv name)
+ #+ECL (si:getenv name)
+ #+SBCL (sb-unix::posix-getenv name)
+ #+LISPWORKS (lispworks:environment-variable name)
+ #+CCL (ccl::getenv name)
+ default))
+
+(swank:create-server :port (parse-integer (my-getenv "SWANK_PORT" "4005"))
+ ;; if non-nil the connection won't be closed
+ ;; after connecting
+ :dont-close t)
diff --git a/vim/bundle/slimv/slime/swank-loader.lisp b/vim/bundle/slimv/slime/swank-loader.lisp
new file mode 100644
index 0000000..7bb81da
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank-loader.lisp
@@ -0,0 +1,366 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-loader.lisp --- Compile and load the Slime backend.
+;;;
+;;; Created 2003, James Bielman <jamesjb@jamesjb.com>
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+;; If you want customize the source- or fasl-directory you can set
+;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
+;; before loading this files.
+;; E.g.:
+;;
+;; (load ".../swank-loader.lisp")
+;; (setq swank-loader::*fasl-directory* "/tmp/fasl/")
+;; (swank-loader:init)
+
+(cl:defpackage :swank-loader
+ (:use :cl)
+ (:export :init
+ :dump-image
+ :list-fasls
+ :*source-directory*
+ :*fasl-directory*))
+
+(cl:in-package :swank-loader)
+
+(defvar *source-directory*
+ (make-pathname :name nil :type nil
+ :defaults (or *load-pathname* *default-pathname-defaults*))
+ "The directory where to look for the source.")
+
+(defparameter *sysdep-files*
+ #+cmu '((swank source-path-parser) (swank source-file-cache) (swank cmucl)
+ (swank gray))
+ #+scl '((swank source-path-parser) (swank source-file-cache) (swank scl)
+ (swank gray))
+ #+sbcl '((swank source-path-parser) (swank source-file-cache) (swank sbcl)
+ (swank gray))
+ #+clozure '(metering (swank ccl) (swank gray))
+ #+lispworks '((swank lispworks) (swank gray))
+ #+allegro '((swank allegro) (swank gray))
+ #+clisp '(xref metering (swank clisp) (swank gray))
+ #+armedbear '((swank abcl))
+ #+cormanlisp '((swank corman) (swank gray))
+ #+ecl '((swank ecl) (swank gray))
+ #+clasp '((swank clasp) (swank gray))
+ #+mkcl '((swank mkcl) (swank gray))
+ )
+
+(defparameter *implementation-features*
+ '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp
+ :armedbear :gcl :ecl :scl :mkcl :clasp))
+
+(defparameter *os-features*
+ '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
+ :unix))
+
+(defparameter *architecture-features*
+ '(:powerpc :ppc :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
+ :sparc64 :sparc :hppa64 :hppa :arm :armv5l :armv6l :armv7l :arm64
+ :pentium3 :pentium4
+ :mips :mipsel
+ :java-1.4 :java-1.5 :java-1.6 :java-1.7))
+
+(defun q (s) (read-from-string s))
+
+#+ecl
+(defun ecl-version-string ()
+ (format nil "~A~@[-~A~]"
+ (lisp-implementation-version)
+ (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)
+ (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id"))))
+ (when (>= (length vcs-id) 8)
+ (subseq vcs-id 0 8))))))
+
+#+clasp
+(defun clasp-version-string ()
+ (format nil "~A~@[-~A~]"
+ (lisp-implementation-version)
+ (core:lisp-implementation-id)))
+
+(defun lisp-version-string ()
+ #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
+ (lisp-implementation-version))
+ #+(or cormanlisp scl mkcl) (lisp-implementation-version)
+ #+sbcl (format nil "~a~:[~;-no-threads~]"
+ (lisp-implementation-version)
+ #+sb-thread nil
+ #-sb-thread t)
+ #+lispworks (lisp-implementation-version)
+ #+allegro (format nil "~@{~a~}"
+ excl::*common-lisp-version-number*
+ (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
+ (if (member :smp *features*) "s" "")
+ (if (member :64bit *features*) "-64bit" "")
+ (excl:ics-target-case
+ (:-ics "")
+ (:+ics "-ics")))
+ #+clisp (let ((s (lisp-implementation-version)))
+ (subseq s 0 (position #\space s)))
+ #+armedbear (lisp-implementation-version)
+ #+ecl (ecl-version-string)
+ #+clasp (clasp-version-string))
+
+(defun unique-dir-name ()
+ "Return a name that can be used as a directory name that is
+unique to a Lisp implementation, Lisp implementation version,
+operating system, and hardware architecture."
+ (flet ((first-of (features)
+ (loop for f in features
+ when (find f *features*) return it))
+ (maybe-warn (value fstring &rest args)
+ (cond (value)
+ (t (apply #'warn fstring args)
+ "unknown"))))
+ (let ((lisp (maybe-warn (first-of *implementation-features*)
+ "No implementation feature found in ~a."
+ *implementation-features*))
+ (os (maybe-warn (first-of *os-features*)
+ "No os feature found in ~a." *os-features*))
+ (arch (maybe-warn (first-of *architecture-features*)
+ "No architecture feature found in ~a."
+ *architecture-features*))
+ (version (maybe-warn (lisp-version-string)
+ "Don't know how to get Lisp ~
+ implementation version.")))
+ (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
+
+(defun file-newer-p (new-file old-file)
+ "Returns true if NEW-FILE is newer than OLD-FILE."
+ (> (file-write-date new-file) (file-write-date old-file)))
+
+(defun string-starts-with (string prefix)
+ (string-equal string prefix :end1 (min (length string) (length prefix))))
+
+(defun slime-version-string ()
+ "Return a string identifying the SLIME version.
+Return nil if nothing appropriate is available."
+ (with-open-file (s (merge-pathnames "slime.el" *source-directory*)
+ :if-does-not-exist nil)
+ (loop with prefix = ";; Version: "
+ for line = (read-line s nil :eof)
+ until (eq line :eof)
+ when (string-starts-with line prefix)
+ return (subseq line (length prefix)))))
+
+(defun default-fasl-dir ()
+ (merge-pathnames
+ (make-pathname
+ :directory `(:relative ".slime" "fasl"
+ ,@(if (slime-version-string) (list (slime-version-string)))
+ ,(unique-dir-name)))
+ (user-homedir-pathname)))
+
+(defvar *fasl-directory* (default-fasl-dir)
+ "The directory where fasl files should be placed.")
+
+(defun binary-pathname (src-pathname binary-dir)
+ "Return the pathname where SRC-PATHNAME's binary should be compiled."
+ (let ((cfp (compile-file-pathname src-pathname)))
+ (merge-pathnames (make-pathname :name (pathname-name cfp)
+ :type (pathname-type cfp))
+ binary-dir)))
+
+(defun handle-swank-load-error (condition context pathname)
+ (fresh-line *error-output*)
+ (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
+ (format *error-output*
+ "~%Error ~A ~A:~% ~A~%"
+ context pathname condition)))
+
+(defun compile-files (files fasl-dir load quiet)
+ "Compile each file in FILES if the source is newer than its
+corresponding binary, or the file preceding it was recompiled.
+If LOAD is true, load the fasl file."
+ (let ((needs-recompile nil)
+ (state :unknown))
+ (dolist (src files)
+ (let ((dest (binary-pathname src fasl-dir)))
+ (handler-bind
+ ((error (lambda (c)
+ (ecase state
+ (:compile (handle-swank-load-error c "compiling" src))
+ (:load (handle-swank-load-error c "loading" dest))
+ (:unknown (handle-swank-load-error c "???ing" src))))))
+ (when (or needs-recompile
+ (not (probe-file dest))
+ (file-newer-p src dest))
+ (ensure-directories-exist dest)
+ ;; need to recompile SRC, so we'll need to recompile
+ ;; everything after this too.
+ (setf needs-recompile t
+ state :compile)
+ (or (compile-file src :output-file dest :print nil
+ :verbose (not quiet))
+ ;; An implementation may not necessarily signal a
+ ;; condition itself when COMPILE-FILE fails (e.g. ECL)
+ (error "COMPILE-FILE returned NIL.")))
+ (when load
+ (setf state :load)
+ (load dest :verbose (not quiet))))))))
+
+#+cormanlisp
+(defun compile-files (files fasl-dir load quiet)
+ "Corman Lisp has trouble with compiled files."
+ (declare (ignore fasl-dir))
+ (when load
+ (dolist (file files)
+ (load file :verbose (not quiet)
+ (force-output)))))
+
+(defun load-user-init-file ()
+ "Load the user init file, return NIL if it does not exist."
+ (load (merge-pathnames (user-homedir-pathname)
+ (make-pathname :name ".swank" :type "lisp"))
+ :if-does-not-exist nil))
+
+(defun load-site-init-file (dir)
+ (load (make-pathname :name "site-init" :type "lisp"
+ :defaults dir)
+ :if-does-not-exist nil))
+
+(defun src-files (names src-dir)
+ (mapcar (lambda (name)
+ (multiple-value-bind (dirs name)
+ (etypecase name
+ (symbol (values '() name))
+ (cons (values (butlast name) (car (last name)))))
+ (make-pathname
+ :directory (append (or (pathname-directory src-dir)
+ '(:relative))
+ (mapcar #'string-downcase dirs))
+ :name (string-downcase name)
+ :type "lisp"
+ :defaults src-dir)))
+ names))
+
+(defvar *swank-files*
+ `(packages
+ (swank backend) ,@*sysdep-files* (swank match) (swank rpc)
+ swank))
+
+(defvar *contribs*
+ '(swank-util swank-repl
+ swank-c-p-c swank-arglists swank-fuzzy
+ swank-fancy-inspector
+ swank-presentations swank-presentation-streams
+ #+(or asdf2 asdf3 sbcl ecl) swank-asdf
+ swank-package-fu
+ swank-hyperdoc
+ #+sbcl swank-sbcl-exts
+ swank-mrepl
+ swank-trace-dialog
+ swank-macrostep
+ swank-quicklisp)
+ "List of names for contrib modules.")
+
+(defun append-dir (absolute name)
+ (merge-pathnames
+ (make-pathname :directory `(:relative ,name) :defaults absolute)
+ absolute))
+
+(defun contrib-dir (base-dir)
+ (append-dir base-dir "contrib"))
+
+(defun load-swank (&key (src-dir *source-directory*)
+ (fasl-dir *fasl-directory*)
+ quiet)
+ (with-compilation-unit ()
+ (compile-files (src-files *swank-files* src-dir) fasl-dir t quiet))
+ (funcall (q "swank::before-init")
+ (slime-version-string)
+ (list (contrib-dir fasl-dir)
+ (contrib-dir src-dir))))
+
+(defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir)
+ (let ((newest (reduce #'max (mapcar #'file-write-date swank-files))))
+ (dolist (src contrib-files)
+ (let ((fasl (binary-pathname src fasl-dir)))
+ (when (and (probe-file fasl)
+ (<= (file-write-date fasl) newest))
+ (delete-file fasl))))))
+
+(defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
+ (fasl-dir (contrib-dir *fasl-directory*))
+ (swank-src-dir *source-directory*)
+ load quiet)
+ (let* ((swank-src-files (src-files *swank-files* swank-src-dir))
+ (contrib-src-files (src-files *contribs* src-dir)))
+ (delete-stale-contrib-fasl-files swank-src-files contrib-src-files
+ fasl-dir)
+ (compile-files contrib-src-files fasl-dir load quiet)))
+
+(defun loadup ()
+ (load-swank)
+ (compile-contribs :load t))
+
+(defun setup ()
+ (load-site-init-file *source-directory*)
+ (load-user-init-file)
+ (when (#-clisp probe-file
+ #+clisp ext:probe-directory
+ (contrib-dir *source-directory*))
+ (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
+ (funcall (q "swank::init")))
+
+(defun list-swank-packages ()
+ (remove-if-not (lambda (package)
+ (let ((name (package-name package)))
+ (and (string-not-equal name "swank-loader")
+ (string-starts-with name "swank"))))
+ (list-all-packages)))
+
+(defun delete-packages (packages)
+ (dolist (package packages)
+ (flet ((handle-package-error (c)
+ (let ((pkgs (set-difference (package-used-by-list package)
+ packages)))
+ (when pkgs
+ (warn "deleting ~a which is used by ~{~a~^, ~}."
+ package pkgs))
+ (continue c))))
+ (handler-bind ((package-error #'handle-package-error))
+ (delete-package package)))))
+
+(defun init (&key delete reload load-contribs (setup t)
+ (quiet (not *load-verbose*)))
+ "Load SWANK and initialize some global variables.
+If DELETE is true, delete any existing SWANK packages.
+If RELOAD is true, reload SWANK, even if the SWANK package already exists.
+If LOAD-CONTRIBS is true, load all contribs
+If SETUP is true, load user init files and initialize some
+global variabes in SWANK."
+ (when (and delete (find-package :swank))
+ (delete-packages (list-swank-packages)))
+ (cond ((or (not (find-package :swank)) reload)
+ (load-swank :quiet quiet))
+ (t
+ (warn "Not reloading SWANK. Package already exists.")))
+ (when load-contribs
+ (compile-contribs :load t :quiet quiet))
+ (when setup
+ (setup)))
+
+(defun dump-image (filename)
+ (init :setup nil)
+ (funcall (q "swank/backend:save-image") filename))
+
+(defun list-fasls (&key (include-contribs t) (compile t)
+ (quiet (not *compile-verbose*)))
+ "List up SWANK's fasls along with their dependencies."
+ (flet ((collect-fasls (files fasl-dir)
+ (when compile
+ (compile-files files fasl-dir nil quiet))
+ (loop for src in files
+ when (probe-file (binary-pathname src fasl-dir))
+ collect it)))
+ (append (collect-fasls (src-files *swank-files* *source-directory*)
+ *fasl-directory*)
+ (when include-contribs
+ (collect-fasls (src-files *contribs*
+ (contrib-dir *source-directory*))
+ (contrib-dir *fasl-directory*))))))
diff --git a/vim/bundle/slimv/slime/swank.asd b/vim/bundle/slimv/slime/swank.asd
new file mode 100644
index 0000000..d9a7627
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank.asd
@@ -0,0 +1,37 @@
+;;; -*- lisp -*-
+
+;; ASDF system definition for loading the Swank server independently
+;; of Emacs.
+;;
+;; This is only useful if you want to start a Swank server in a Lisp
+;; processes that doesn't run under Emacs. Lisp processes created by
+;; `M-x slime' automatically start the server.
+
+;; Usage:
+;;
+;; (require :swank)
+;; (swank:create-swank-server PORT) => ACTUAL-PORT
+;;
+;; (PORT can be zero to mean "any available port".)
+;; Then the Swank server is running on localhost:ACTUAL-PORT. You can
+;; use `M-x slime-connect' to connect Emacs to it.
+;;
+;; This code has been placed in the Public Domain. All warranties
+;; are disclaimed.
+
+(defpackage :swank-loader
+ (:use :cl))
+
+(in-package :swank-loader)
+
+(defclass swank-loader-file (asdf:cl-source-file) ())
+
+;;;; after loading run init
+
+(defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file))
+ (load (asdf::component-pathname f))
+ (funcall (read-from-string "swank-loader::init") :reload t))
+
+(asdf:defsystem :swank
+ :default-component-class swank-loader-file
+ :components ((:file "swank-loader")))
diff --git a/vim/bundle/slimv/slime/swank.lisp b/vim/bundle/slimv/slime/swank.lisp
new file mode 100644
index 0000000..909bd19
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank.lisp
@@ -0,0 +1,3743 @@
+;;;; swank.lisp --- Server for SLIME commands.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+;;; This file defines the "Swank" TCP server for Emacs to talk to. The
+;;; code in this file is purely portable Common Lisp. We do require a
+;;; smattering of non-portable functions in order to write the server,
+;;; so we have defined them in `swank/backend.lisp' and implemented
+;;; them separately for each Lisp implementation. These extensions are
+;;; available to us here via the `SWANK/BACKEND' package.
+
+(in-package :swank)
+;;;; Top-level variables, constants, macros
+
+(defconstant cl-package (find-package :cl)
+ "The COMMON-LISP package.")
+
+(defconstant keyword-package (find-package :keyword)
+ "The KEYWORD package.")
+
+(defconstant default-server-port 4005
+ "The default TCP port for the server (when started manually).")
+
+(defvar *swank-debug-p* t
+ "When true, print extra debugging information.")
+
+(defvar *backtrace-pprint-dispatch-table*
+ (let ((table (copy-pprint-dispatch nil)))
+ (flet ((print-string (stream string)
+ (cond (*print-escape*
+ (escape-string string stream
+ :map '((#\" . "\\\"")
+ (#\\ . "\\\\")
+ (#\newline . "\\n")
+ (#\return . "\\r"))))
+ (t (write-string string stream)))))
+ (set-pprint-dispatch 'string #'print-string 0 table)
+ table)))
+
+(defvar *backtrace-printer-bindings*
+ `((*print-pretty* . t)
+ (*print-readably* . nil)
+ (*print-level* . 4)
+ (*print-length* . 6)
+ (*print-lines* . 1)
+ (*print-right-margin* . 200)
+ (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*))
+ "Pretter settings for printing backtraces.")
+
+(defvar *default-worker-thread-bindings* '()
+ "An alist to initialize dynamic variables in worker threads.
+The list has the form ((VAR . VALUE) ...). Each variable VAR will be
+bound to the corresponding VALUE.")
+
+(defun call-with-bindings (alist fun)
+ "Call FUN with variables bound according to ALIST.
+ALIST is a list of the form ((VAR . VAL) ...)."
+ (if (null alist)
+ (funcall fun)
+ (let* ((rlist (reverse alist))
+ (vars (mapcar #'car rlist))
+ (vals (mapcar #'cdr rlist)))
+ (progv vars vals
+ (funcall fun)))))
+
+(defmacro with-bindings (alist &body body)
+ "See `call-with-bindings'."
+ `(call-with-bindings ,alist (lambda () ,@body)))
+
+;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
+;;; RPC.
+
+(defmacro defslimefun (name arglist &body rest)
+ "A DEFUN for functions that Emacs can call by RPC."
+ `(progn
+ (defun ,name ,arglist ,@rest)
+ ;; see <http://www.franz.com/support/documentation/6.2/\
+ ;; doc/pages/variables/compiler/\
+ ;; s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (export ',name (symbol-package ',name)))))
+
+(defun missing-arg ()
+ "A function that the compiler knows will never to return a value.
+You can use (MISSING-ARG) as the initform for defstruct slots that
+must always be supplied. This way the :TYPE slot option need not
+include some arbitrary initial value like NIL."
+ (error "A required &KEY or &OPTIONAL argument was not supplied."))
+
+
+;;;; Hooks
+;;;
+;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
+;;; simple indirection. The interface is more CLish than the Emacs
+;;; Lisp one.
+
+(defmacro add-hook (place function)
+ "Add FUNCTION to the list of values on PLACE."
+ `(pushnew ,function ,place))
+
+(defun run-hook (functions &rest arguments)
+ "Call each of FUNCTIONS with ARGUMENTS."
+ (dolist (function functions)
+ (apply function arguments)))
+
+(defvar *new-connection-hook* '()
+ "This hook is run each time a connection is established.
+The connection structure is given as the argument.
+Backend code should treat the connection structure as opaque.")
+
+(defvar *connection-closed-hook* '()
+ "This hook is run when a connection is closed.
+The connection as passed as an argument.
+Backend code should treat the connection structure as opaque.")
+
+(defvar *pre-reply-hook* '()
+ "Hook run (without arguments) immediately before replying to an RPC.")
+
+(defvar *after-init-hook* '()
+ "Hook run after user init files are loaded.")
+
+
+;;;; Connections
+;;;
+;;; Connection structures represent the network connections between
+;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
+;;; streams that redirect to Emacs, and optionally a second socket
+;;; used solely to pipe user-output to Emacs (an optimization). This
+;;; is also the place where we keep everything that needs to be
+;;; freed/closed/killed when we disconnect.
+
+(defstruct (connection
+ (:constructor %make-connection)
+ (:conc-name connection.)
+ (:print-function print-connection))
+ ;; The listening socket. (usually closed)
+ (socket (missing-arg) :type t :read-only t)
+ ;; Character I/O stream of socket connection. Read-only to avoid
+ ;; race conditions during initialization.
+ (socket-io (missing-arg) :type stream :read-only t)
+ ;; Optional dedicated output socket (backending `user-output' slot).
+ ;; Has a slot so that it can be closed with the connection.
+ (dedicated-output nil :type (or stream null))
+ ;; Streams that can be used for user interaction, with requests
+ ;; redirected to Emacs.
+ (user-input nil :type (or stream null))
+ (user-output nil :type (or stream null))
+ (user-io nil :type (or stream null))
+ ;; Bindings used for this connection (usually streams)
+ (env '() :type list)
+ ;; A stream that we use for *trace-output*; if nil, we user user-output.
+ (trace-output nil :type (or stream null))
+ ;; A stream where we send REPL results.
+ (repl-results nil :type (or stream null))
+ ;; Cache of macro-indentation information that has been sent to Emacs.
+ ;; This is used for preparing deltas to update Emacs's knowledge.
+ ;; Maps: symbol -> indentation-specification
+ (indentation-cache (make-hash-table :test 'eq) :type hash-table)
+ ;; The list of packages represented in the cache:
+ (indentation-cache-packages '())
+ ;; The communication style used.
+ (communication-style nil :type (member nil :spawn :sigio :fd-handler))
+ )
+
+(defun print-connection (conn stream depth)
+ (declare (ignore depth))
+ (print-unreadable-object (conn stream :type t :identity t)))
+
+(defstruct (singlethreaded-connection (:include connection)
+ (:conc-name sconn.))
+ ;; The SIGINT handler we should restore when the connection is
+ ;; closed.
+ saved-sigint-handler
+ ;; A queue of events. Not all events can be processed in order and
+ ;; we need a place to stored them.
+ (event-queue '() :type list)
+ ;; A counter that is incremented whenever an event is added to the
+ ;; queue. This is used to detected modifications to the event queue
+ ;; by interrupts. The counter wraps around.
+ (events-enqueued 0 :type fixnum))
+
+(defstruct (multithreaded-connection (:include connection)
+ (:conc-name mconn.))
+ ;; In multithreaded systems we delegate certain tasks to specific
+ ;; threads. The `reader-thread' is responsible for reading network
+ ;; requests from Emacs and sending them to the `control-thread'; the
+ ;; `control-thread' is responsible for dispatching requests to the
+ ;; threads that should handle them; the `repl-thread' is the one
+ ;; that evaluates REPL expressions. The control thread dispatches
+ ;; all REPL evaluations to the REPL thread and for other requests it
+ ;; spawns new threads.
+ reader-thread
+ control-thread
+ repl-thread
+ auto-flush-thread
+ indentation-cache-thread
+ ;; List of threads that are currently processing requests. We use
+ ;; this to find the newest/current thread for an interrupt. In the
+ ;; future we may store here (thread . request-tag) pairs so that we
+ ;; can interrupt specific requests.
+ (active-threads '() :type list)
+ )
+
+(defvar *emacs-connection* nil
+ "The connection to Emacs currently in use.")
+
+(defun make-connection (socket stream style)
+ (let ((conn (funcall (ecase style
+ (:spawn
+ #'make-multithreaded-connection)
+ ((:sigio nil :fd-handler)
+ #'make-singlethreaded-connection))
+ :socket socket
+ :socket-io stream
+ :communication-style style)))
+ (run-hook *new-connection-hook* conn)
+ (send-to-sentinel `(:add-connection ,conn))
+ conn))
+
+(defslimefun ping (tag)
+ tag)
+
+(defun safe-backtrace ()
+ (ignore-errors
+ (call-with-debugging-environment
+ (lambda () (backtrace 0 nil)))))
+
+(define-condition swank-error (error)
+ ((backtrace :initarg :backtrace :reader swank-error.backtrace)
+ (condition :initarg :condition :reader swank-error.condition))
+ (:report (lambda (c s) (princ (swank-error.condition c) s)))
+ (:documentation "Condition which carries a backtrace."))
+
+(defun signal-swank-error (condition &optional (backtrace (safe-backtrace)))
+ (error 'swank-error :condition condition :backtrace backtrace))
+
+(defvar *debug-on-swank-protocol-error* nil
+ "When non-nil invoke the system debugger on errors that were
+signalled during decoding/encoding the wire protocol. Do not set this
+to T unless you want to debug swank internals.")
+
+(defmacro with-swank-error-handler ((connection) &body body)
+ "Close the connection on internal `swank-error's."
+ (let ((conn (gensym)))
+ `(let ((,conn ,connection))
+ (handler-case
+ (handler-bind ((swank-error
+ (lambda (condition)
+ (when *debug-on-swank-protocol-error*
+ (invoke-default-debugger condition)))))
+ (progn . ,body))
+ (swank-error (condition)
+ (close-connection ,conn
+ (swank-error.condition condition)
+ (swank-error.backtrace condition)))))))
+
+(defmacro with-panic-handler ((connection) &body body)
+ "Close the connection on unhandled `serious-condition's."
+ (let ((conn (gensym)))
+ `(let ((,conn ,connection))
+ (handler-bind ((serious-condition
+ (lambda (condition)
+ (close-connection ,conn condition (safe-backtrace))
+ (abort condition))))
+ . ,body))))
+
+(add-hook *new-connection-hook* 'notify-backend-of-connection)
+(defun notify-backend-of-connection (connection)
+ (declare (ignore connection))
+ (emacs-connected))
+
+
+;;;; Utilities
+
+
+;;;;; Logging
+
+(defvar *swank-io-package*
+ (let ((package (make-package :swank-io-package :use '())))
+ (import '(nil t quote) package)
+ package))
+
+(defvar *log-events* nil)
+
+(defun init-log-output ()
+ (unless *log-output*
+ (setq *log-output* (real-output-stream *error-output*))))
+
+(add-hook *after-init-hook* 'init-log-output)
+
+(defun real-input-stream (stream)
+ (typecase stream
+ (synonym-stream
+ (real-input-stream (symbol-value (synonym-stream-symbol stream))))
+ (two-way-stream
+ (real-input-stream (two-way-stream-input-stream stream)))
+ (t stream)))
+
+(defun real-output-stream (stream)
+ (typecase stream
+ (synonym-stream
+ (real-output-stream (symbol-value (synonym-stream-symbol stream))))
+ (two-way-stream
+ (real-output-stream (two-way-stream-output-stream stream)))
+ (t stream)))
+
+(defvar *event-history* (make-array 40 :initial-element nil)
+ "A ring buffer to record events for better error messages.")
+(defvar *event-history-index* 0)
+(defvar *enable-event-history* t)
+
+(defun log-event (format-string &rest args)
+ "Write a message to *terminal-io* when *log-events* is non-nil.
+Useful for low level debugging."
+ (with-standard-io-syntax
+ (let ((*print-readably* nil)
+ (*print-pretty* nil)
+ (*package* *swank-io-package*))
+ (when *enable-event-history*
+ (setf (aref *event-history* *event-history-index*)
+ (format nil "~?" format-string args))
+ (setf *event-history-index*
+ (mod (1+ *event-history-index*) (length *event-history*))))
+ (when *log-events*
+ (write-string (escape-non-ascii (format nil "~?" format-string args))
+ *log-output*)
+ (force-output *log-output*)))))
+
+(defun event-history-to-list ()
+ "Return the list of events (older events first)."
+ (let ((arr *event-history*)
+ (idx *event-history-index*))
+ (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
+
+(defun clear-event-history ()
+ (fill *event-history* nil)
+ (setq *event-history-index* 0))
+
+(defun dump-event-history (stream)
+ (dolist (e (event-history-to-list))
+ (dump-event e stream)))
+
+(defun dump-event (event stream)
+ (cond ((stringp event)
+ (write-string (escape-non-ascii event) stream))
+ ((null event))
+ (t
+ (write-string
+ (escape-non-ascii (format nil "Unexpected event: ~A~%" event))
+ stream))))
+
+(defun escape-non-ascii (string)
+ "Return a string like STRING but with non-ascii chars escaped."
+ (cond ((ascii-string-p string) string)
+ (t (with-output-to-string (out)
+ (loop for c across string do
+ (cond ((ascii-char-p c) (write-char c out))
+ (t (format out "\\x~4,'0X" (char-code c)))))))))
+
+(defun ascii-string-p (o)
+ (and (stringp o)
+ (every #'ascii-char-p o)))
+
+(defun ascii-char-p (c)
+ (<= (char-code c) 127))
+
+
+;;;;; Helper macros
+
+(defmacro dcase (value &body patterns)
+ "Dispatch VALUE to one of PATTERNS.
+A cross between `case' and `destructuring-bind'.
+The pattern syntax is:
+ ((HEAD . ARGS) . BODY)
+The list of patterns is searched for a HEAD `eq' to the car of
+VALUE. If one is found, the BODY is executed with ARGS bound to the
+corresponding values in the CDR of VALUE."
+ (let ((operator (gensym "op-"))
+ (operands (gensym "rand-"))
+ (tmp (gensym "tmp-")))
+ `(let* ((,tmp ,value)
+ (,operator (car ,tmp))
+ (,operands (cdr ,tmp)))
+ (case ,operator
+ ,@(loop for (pattern . body) in patterns collect
+ (if (eq pattern t)
+ `(t ,@body)
+ (destructuring-bind (op &rest rands) pattern
+ `(,op (destructuring-bind ,rands ,operands
+ ,@body)))))
+ ,@(if (eq (caar (last patterns)) t)
+ '()
+ `((t (error "dcase failed: ~S" ,tmp))))))))
+
+
+;;;; Interrupt handling
+
+;; Usually we'd like to enter the debugger when an interrupt happens.
+;; But for some operations, in particular send&receive, it's crucial
+;; that those are not interrupted when the mailbox is in an
+;; inconsistent/locked state. Obviously, if send&receive don't work we
+;; can't communicate and the debugger will not work. To solve that
+;; problem, we try to handle interrupts only at certain safe-points.
+;;
+;; Whenever an interrupt happens we call the function
+;; INVOKE-OR-QUEUE-INTERRUPT. Usually this simply invokes the
+;; debugger, but if interrupts are disabled the interrupt is put in a
+;; queue for later processing. At safe-points, we call
+;; CHECK-SLIME-INTERRUPTS which looks at the queue and invokes the
+;; debugger if needed.
+;;
+;; The queue for interrupts is stored in a thread local variable.
+;; WITH-CONNECTION sets it up. WITH-SLIME-INTERRUPTS allows
+;; interrupts, i.e. the debugger is entered immediately. When we call
+;; "user code" or non-problematic code we allow interrupts. When
+;; inside WITHOUT-SLIME-INTERRUPTS, interrupts are queued. When we
+;; switch from "user code" to more delicate operations we need to
+;; disable interrupts. In particular, interrupts should be disabled
+;; for SEND and RECEIVE-IF.
+
+;; If true execute interrupts, otherwise queue them.
+;; Note: `with-connection' binds *pending-slime-interrupts*.
+(defvar *slime-interrupts-enabled*)
+
+(defmacro with-interrupts-enabled% (flag body)
+ `(progn
+ ,@(if flag '((check-slime-interrupts)))
+ (multiple-value-prog1
+ (let ((*slime-interrupts-enabled* ,flag))
+ ,@body)
+ ,@(if flag '((check-slime-interrupts))))))
+
+(defmacro with-slime-interrupts (&body body)
+ `(with-interrupts-enabled% t ,body))
+
+(defmacro without-slime-interrupts (&body body)
+ `(with-interrupts-enabled% nil ,body))
+
+(defun invoke-or-queue-interrupt (function)
+ (log-event "invoke-or-queue-interrupt: ~a~%" function)
+ (cond ((not (boundp '*slime-interrupts-enabled*))
+ (without-slime-interrupts
+ (funcall function)))
+ (*slime-interrupts-enabled*
+ (log-event "interrupts-enabled~%")
+ (funcall function))
+ (t
+ (setq *pending-slime-interrupts*
+ (nconc *pending-slime-interrupts*
+ (list function)))
+ (cond ((cdr *pending-slime-interrupts*)
+ (log-event "too many queued interrupts~%")
+ (with-simple-restart (continue "Continue from interrupt")
+ (handler-bind ((serious-condition #'invoke-slime-debugger))
+ (check-slime-interrupts))))
+ (t
+ (log-event "queue-interrupt: ~a~%" function)
+ (when *interrupt-queued-handler*
+ (funcall *interrupt-queued-handler*)))))))
+
+
+;;; FIXME: poor name?
+(defmacro with-io-redirection ((connection) &body body)
+ "Execute BODY I/O redirection to CONNECTION. "
+ `(with-bindings (connection.env ,connection)
+ . ,body))
+
+;; Thread local variable used for flow-control.
+;; It's bound by `with-connection'.
+(defvar *send-counter*)
+
+(defmacro with-connection ((connection) &body body)
+ "Execute BODY in the context of CONNECTION."
+ `(let ((connection ,connection)
+ (function (lambda () . ,body)))
+ (if (eq *emacs-connection* connection)
+ (funcall function)
+ (let ((*emacs-connection* connection)
+ (*pending-slime-interrupts* '())
+ (*send-counter* 0))
+ (without-slime-interrupts
+ (with-swank-error-handler (connection)
+ (with-io-redirection (connection)
+ (call-with-debugger-hook #'swank-debugger-hook
+ function))))))))
+
+(defun call-with-retry-restart (msg thunk)
+ (loop (with-simple-restart (retry "~a" msg)
+ (return (funcall thunk)))))
+
+(defmacro with-retry-restart ((&key (msg "Retry.")) &body body)
+ (check-type msg string)
+ `(call-with-retry-restart ,msg (lambda () ,@body)))
+
+(defmacro with-struct* ((conc-name get obj) &body body)
+ (let ((var (gensym)))
+ `(let ((,var ,obj))
+ (macrolet ((,get (slot)
+ (let ((getter (intern (concatenate 'string
+ ',(string conc-name)
+ (string slot))
+ (symbol-package ',conc-name))))
+ `(,getter ,',var))))
+ ,@body))))
+
+(defmacro define-special (name doc)
+ "Define a special variable NAME with doc string DOC.
+This is like defvar, but NAME will not be initialized."
+ `(progn
+ (defvar ,name)
+ (setf (documentation ',name 'variable) ,doc)))
+
+
+;;;;; Sentinel
+;;;
+;;; The sentinel thread manages some global lists.
+;;; FIXME: Overdesigned?
+
+(defvar *connections* '()
+ "List of all active connections, with the most recent at the front.")
+
+(defvar *servers* '()
+ "A list ((server-socket port thread) ...) describing the listening sockets.
+Used to close sockets on server shutdown or restart.")
+
+;; FIXME: we simply access the global variable here. We could ask the
+;; sentinel thread instead but then we still have the problem that the
+;; connection could be closed before we use it.
+(defun default-connection ()
+ "Return the 'default' Emacs connection.
+This connection can be used to talk with Emacs when no specific
+connection is in use, i.e. *EMACS-CONNECTION* is NIL.
+
+The default connection is defined (quite arbitrarily) as the most
+recently established one."
+ (car *connections*))
+
+(defun start-sentinel ()
+ (unless (find-registered 'sentinel)
+ (let ((thread (spawn #'sentinel :name "Swank Sentinel")))
+ (register-thread 'sentinel thread))))
+
+(defun sentinel ()
+ (catch 'exit-sentinel
+ (loop (sentinel-serve (receive)))))
+
+(defun send-to-sentinel (msg)
+ (let ((sentinel (find-registered 'sentinel)))
+ (cond (sentinel (send sentinel msg))
+ (t (sentinel-serve msg)))))
+
+(defun sentinel-serve (msg)
+ (dcase msg
+ ((:add-connection conn)
+ (push conn *connections*))
+ ((:close-connection connection condition backtrace)
+ (close-connection% connection condition backtrace)
+ (sentinel-maybe-exit))
+ ((:add-server socket port thread)
+ (push (list socket port thread) *servers*))
+ ((:stop-server key port)
+ (sentinel-stop-server key port)
+ (sentinel-maybe-exit))))
+
+(defun sentinel-stop-server (key value)
+ (let ((probe (find value *servers* :key (ecase key
+ (:socket #'car)
+ (:port #'cadr)))))
+ (cond (probe
+ (setq *servers* (delete probe *servers*))
+ (destructuring-bind (socket _port thread) probe
+ (declare (ignore _port))
+ (ignore-errors (close-socket socket))
+ (when (and thread
+ (thread-alive-p thread)
+ (not (eq thread (current-thread))))
+ (kill-thread thread))))
+ (t
+ (warn "No server for ~s: ~s" key value)))))
+
+(defun sentinel-maybe-exit ()
+ (when (and (null *connections*)
+ (null *servers*)
+ (and (current-thread)
+ (eq (find-registered 'sentinel)
+ (current-thread))))
+ (register-thread 'sentinel nil)
+ (throw 'exit-sentinel nil)))
+
+
+;;;;; Misc
+
+(defun use-threads-p ()
+ (eq (connection.communication-style *emacs-connection*) :spawn))
+
+(defun current-thread-id ()
+ (thread-id (current-thread)))
+
+(declaim (inline ensure-list))
+(defun ensure-list (thing)
+ (if (listp thing) thing (list thing)))
+
+
+;;;;; Symbols
+
+;; FIXME: this docstring is more confusing than helpful.
+(defun symbol-status (symbol &optional (package (symbol-package symbol)))
+ "Returns one of
+
+ :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
+
+ :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
+
+ :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
+ but is not _present_ in PACKAGE,
+
+ or NIL if SYMBOL is not _accessible_ in PACKAGE.
+
+
+Be aware not to get confused with :INTERNAL and how \"internal
+symbols\" are defined in the spec; there is a slight mismatch of
+definition with the Spec and what's commonly meant when talking
+about internal symbols most times. As the spec says:
+
+ In a package P, a symbol S is
+
+ _accessible_ if S is either _present_ in P itself or was
+ inherited from another package Q (which implies
+ that S is _external_ in Q.)
+
+ You can check that with: (AND (SYMBOL-STATUS S P) T)
+
+
+ _present_ if either P is the /home package/ of S or S has been
+ imported into P or exported from P by IMPORT, or
+ EXPORT respectively.
+
+ Or more simply, if S is not _inherited_.
+
+ You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
+ (AND STATUS
+ (NOT (EQ STATUS :INHERITED))))
+
+
+ _external_ if S is going to be inherited into any package that
+ /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
+ DEFPACKAGE.
+
+ Note that _external_ implies _present_, since to
+ make a symbol _external_, you'd have to use EXPORT
+ which will automatically make the symbol _present_.
+
+ You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
+
+
+ _internal_ if S is _accessible_ but not _external_.
+
+ You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
+ (AND STATUS
+ (NOT (EQ STATUS :EXTERNAL))))
+
+
+ Notice that this is *different* to
+ (EQ (SYMBOL-STATUS S P) :INTERNAL)
+ because what the spec considers _internal_ is split up into two
+ explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
+ CL:FIND-SYMBOL does.
+
+ The rationale is that most times when you speak about \"internal\"
+ symbols, you're actually not including the symbols inherited
+ from other packages, but only about the symbols directly specific
+ to the package in question.
+"
+ (when package ; may be NIL when symbol is completely uninterned.
+ (check-type symbol symbol) (check-type package package)
+ (multiple-value-bind (present-symbol status)
+ (find-symbol (symbol-name symbol) package)
+ (and (eq symbol present-symbol) status))))
+
+(defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
+ "True if SYMBOL is external in PACKAGE.
+If PACKAGE is not specified, the home package of SYMBOL is used."
+ (eq (symbol-status symbol package) :external))
+
+
+;;;; TCP Server
+
+(defvar *communication-style* (preferred-communication-style))
+
+(defvar *dont-close* nil
+ "Default value of :dont-close argument to start-server and
+ create-server.")
+
+(defun start-server (port-file &key (style *communication-style*)
+ (dont-close *dont-close*))
+ "Start the server and write the listen port number to PORT-FILE.
+This is the entry point for Emacs."
+ (setup-server 0
+ (lambda (port) (announce-server-port port-file port))
+ style dont-close nil))
+
+(defun create-server (&key (port default-server-port)
+ (style *communication-style*)
+ (dont-close *dont-close*)
+ backlog)
+ "Start a SWANK server on PORT running in STYLE.
+If DONT-CLOSE is true then the listen socket will accept multiple
+connections, otherwise it will be closed after the first."
+ (setup-server port #'simple-announce-function
+ style dont-close backlog))
+
+(defun find-external-format-or-lose (coding-system)
+ (or (find-external-format coding-system)
+ (error "Unsupported coding system: ~s" coding-system)))
+
+(defparameter *loopback-interface* "127.0.0.1")
+
+(defmacro restart-loop (form &body clauses)
+ "Executes FORM, with restart-case CLAUSES which have a chance to modify FORM's
+environment before trying again (by returning normally) or giving up (through an
+explicit transfer of control), all within an implicit block named nil.
+e.g.: (restart-loop (http-request url) (use-value (new) (setq url new)))"
+ `(loop (restart-case (return ,form) ,@clauses)))
+
+(defun socket-quest (port backlog)
+ (restart-loop (create-socket *loopback-interface* port :backlog backlog)
+ (use-value (&optional (new-port (1+ port)))
+ :report (lambda (stream) (format stream "Try a port other than ~D" port))
+ :interactive
+ (lambda ()
+ (format *query-io* "Enter port (defaults to ~D): " (1+ port))
+ (finish-output *query-io*) ; necessary for tunnels
+ (ignore-errors (list (parse-integer (read-line *query-io*)))))
+ (setq port new-port))))
+
+(defun setup-server (port announce-fn style dont-close backlog)
+ (init-log-output)
+ (let* ((socket (socket-quest port backlog))
+ (port (local-port socket)))
+ (funcall announce-fn port)
+ (labels ((serve () (accept-connections socket style dont-close))
+ (note () (send-to-sentinel `(:add-server ,socket ,port
+ ,(current-thread))))
+ (serve-loop () (note) (loop do (serve) while dont-close)))
+ (ecase style
+ (:spawn (initialize-multiprocessing
+ (lambda ()
+ (start-sentinel)
+ (spawn #'serve-loop :name (format nil "Swank ~s" port)))))
+ ((:fd-handler :sigio)
+ (note)
+ (add-fd-handler socket #'serve))
+ ((nil) (serve-loop))))
+ port))
+
+(defun stop-server (port)
+ "Stop server running on PORT."
+ (send-to-sentinel `(:stop-server :port ,port)))
+
+(defun restart-server (&key (port default-server-port)
+ (style *communication-style*)
+ (dont-close *dont-close*))
+ "Stop the server listening on PORT, then start a new SWANK server
+on PORT running in STYLE. If DONT-CLOSE is true then the listen socket
+will accept multiple connections, otherwise it will be closed after the
+first."
+ (stop-server port)
+ (sleep 5)
+ (create-server :port port :style style :dont-close dont-close))
+
+(defun accept-connections (socket style dont-close)
+ (let ((client (unwind-protect
+ (accept-connection socket :external-format nil
+ :buffering t)
+ (unless dont-close
+ (close-socket socket)))))
+ (authenticate-client client)
+ (serve-requests (make-connection socket client style))
+ (unless dont-close
+ (send-to-sentinel `(:stop-server :socket ,socket)))))
+
+(defun authenticate-client (stream)
+ (let ((secret (slime-secret)))
+ (when secret
+ (set-stream-timeout stream 20)
+ (let ((first-val (decode-message stream)))
+ (unless (and (stringp first-val) (string= first-val secret))
+ (error "Incoming connection doesn't know the password.")))
+ (set-stream-timeout stream nil))))
+
+(defun slime-secret ()
+ "Finds the magic secret from the user's home directory. Returns nil
+if the file doesn't exist; otherwise the first line of the file."
+ (with-open-file (in
+ (merge-pathnames (user-homedir-pathname) #p".slime-secret")
+ :if-does-not-exist nil)
+ (and in (read-line in nil ""))))
+
+(defun serve-requests (connection)
+ "Read and process all requests on connections."
+ (etypecase connection
+ (multithreaded-connection
+ (spawn-threads-for-connection connection))
+ (singlethreaded-connection
+ (ecase (connection.communication-style connection)
+ ((nil) (simple-serve-requests connection))
+ (:sigio (install-sigio-handler connection))
+ (:fd-handler (install-fd-handler connection))))))
+
+(defun stop-serving-requests (connection)
+ (etypecase connection
+ (multithreaded-connection
+ (cleanup-connection-threads connection))
+ (singlethreaded-connection
+ (ecase (connection.communication-style connection)
+ ((nil))
+ (:sigio (deinstall-sigio-handler connection))
+ (:fd-handler (deinstall-fd-handler connection))))))
+
+(defun announce-server-port (file port)
+ (with-open-file (s file
+ :direction :output
+ :if-exists :error
+ :if-does-not-exist :create)
+ (format s "~S~%" port))
+ (simple-announce-function port))
+
+(defun simple-announce-function (port)
+ (when *swank-debug-p*
+ (format *log-output* "~&;; Swank started at port: ~D.~%" port)
+ (force-output *log-output*)))
+
+
+;;;;; Event Decoding/Encoding
+
+(defun decode-message (stream)
+ "Read an S-expression from STREAM using the SLIME protocol."
+ (log-event "decode-message~%")
+ (without-slime-interrupts
+ (handler-bind ((error #'signal-swank-error))
+ (handler-case (read-message stream *swank-io-package*)
+ (swank-reader-error (c)
+ `(:reader-error ,(swank-reader-error.packet c)
+ ,(swank-reader-error.cause c)))))))
+
+(defun encode-message (message stream)
+ "Write an S-expression to STREAM using the SLIME protocol."
+ (log-event "encode-message~%")
+ (without-slime-interrupts
+ (handler-bind ((error #'signal-swank-error))
+ (write-message message *swank-io-package* stream))))
+
+
+;;;;; Event Processing
+
+(defvar *sldb-quit-restart* nil
+ "The restart that will be invoked when the user calls sldb-quit.")
+
+;; Establish a top-level restart and execute BODY.
+;; Execute K if the restart is invoked.
+(defmacro with-top-level-restart ((connection k) &body body)
+ `(with-connection (,connection)
+ (restart-case
+ (let ((*sldb-quit-restart* (find-restart 'abort)))
+ ,@body)
+ (abort (&optional v)
+ :report "Return to SLIME's top level."
+ (declare (ignore v))
+ (force-user-output)
+ ,k))))
+
+(defun handle-requests (connection &optional timeout)
+ "Read and process :emacs-rex requests.
+The processing is done in the extent of the toplevel restart."
+ (with-connection (connection)
+ (cond (*sldb-quit-restart*
+ (process-requests timeout))
+ (t
+ (tagbody
+ start
+ (with-top-level-restart (connection (go start))
+ (process-requests timeout)))))))
+
+(defun process-requests (timeout)
+ "Read and process requests from Emacs."
+ (loop
+ (multiple-value-bind (event timeout?)
+ (wait-for-event `(or (:emacs-rex . _)
+ (:emacs-channel-send . _))
+ timeout)
+ (when timeout? (return))
+ (dcase event
+ ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
+ ((:emacs-channel-send channel (selector &rest args))
+ (channel-send channel selector args))))))
+
+(defun current-socket-io ()
+ (connection.socket-io *emacs-connection*))
+
+(defun close-connection (connection condition backtrace)
+ (send-to-sentinel `(:close-connection ,connection ,condition ,backtrace)))
+
+(defun close-connection% (c condition backtrace)
+ (let ((*debugger-hook* nil))
+ (log-event "close-connection: ~a ...~%" condition)
+ (format *log-output* "~&;; swank:close-connection: ~A~%"
+ (escape-non-ascii (safe-condition-message condition)))
+ (stop-serving-requests c)
+ (close (connection.socket-io c))
+ (when (connection.dedicated-output c)
+ (close (connection.dedicated-output c)))
+ (setf *connections* (remove c *connections*))
+ (run-hook *connection-closed-hook* c)
+ (when (and condition (not (typep condition 'end-of-file)))
+ (finish-output *log-output*)
+ (format *log-output* "~&;; Event history start:~%")
+ (dump-event-history *log-output*)
+ (format *log-output* "~
+;; Event history end.~%~
+;; Backtrace:~%~{~A~%~}~
+;; Connection to Emacs lost. [~%~
+;; condition: ~A~%~
+;; type: ~S~%~
+;; style: ~S]~%"
+ (loop for (i f) in backtrace collect
+ (ignore-errors
+ (format nil "~d: ~a" i (escape-non-ascii f))))
+ (escape-non-ascii (safe-condition-message condition) )
+ (type-of condition)
+ (connection.communication-style c)))
+ (finish-output *log-output*)
+ (log-event "close-connection ~a ... done.~%" condition)))
+
+;;;;;; Thread based communication
+
+(defun read-loop (connection)
+ (let ((input-stream (connection.socket-io connection))
+ (control-thread (mconn.control-thread connection)))
+ (with-swank-error-handler (connection)
+ (loop (send control-thread (decode-message input-stream))))))
+
+(defun dispatch-loop (connection)
+ (let ((*emacs-connection* connection))
+ (with-panic-handler (connection)
+ (loop (dispatch-event connection (receive))))))
+
+(defvar *auto-flush-interval* 0.2)
+
+(defun auto-flush-loop (stream)
+ (loop
+ (when (not (and (open-stream-p stream)
+ (output-stream-p stream)))
+ (return nil))
+ (force-output stream)
+ (sleep *auto-flush-interval*)))
+
+(defgeneric thread-for-evaluation (connection id)
+ (:documentation "Find or create a thread to evaluate the next request.")
+ (:method ((connection multithreaded-connection) (id (eql t)))
+ (spawn-worker-thread connection))
+ (:method ((connection multithreaded-connection) (id (eql :find-existing)))
+ (car (mconn.active-threads connection)))
+ (:method (connection (id integer))
+ (declare (ignorable connection))
+ (find-thread id))
+ (:method ((connection singlethreaded-connection) id)
+ (declare (ignorable connection connection id))
+ (current-thread)))
+
+(defun interrupt-worker-thread (connection id)
+ (let ((thread (thread-for-evaluation connection
+ (cond ((eq id t) :find-existing)
+ (t id)))))
+ (log-event "interrupt-worker-thread: ~a ~a~%" id thread)
+ (if thread
+ (etypecase connection
+ (multithreaded-connection
+ (interrupt-thread thread
+ (lambda ()
+ ;; safely interrupt THREAD
+ (invoke-or-queue-interrupt #'simple-break))))
+ (singlethreaded-connection
+ (simple-break)))
+ (encode-message (list :debug-condition (current-thread-id)
+ (format nil "Thread with id ~a not found"
+ id))
+ (current-socket-io)))))
+
+(defun spawn-worker-thread (connection)
+ (spawn (lambda ()
+ (with-bindings *default-worker-thread-bindings*
+ (with-top-level-restart (connection nil)
+ (apply #'eval-for-emacs
+ (cdr (wait-for-event `(:emacs-rex . _)))))))
+ :name "worker"))
+
+(defun add-active-thread (connection thread)
+ (etypecase connection
+ (multithreaded-connection
+ (push thread (mconn.active-threads connection)))
+ (singlethreaded-connection)))
+
+(defun remove-active-thread (connection thread)
+ (etypecase connection
+ (multithreaded-connection
+ (setf (mconn.active-threads connection)
+ (delete thread (mconn.active-threads connection) :count 1)))
+ (singlethreaded-connection)))
+
+(defun dispatch-event (connection event)
+ "Handle an event triggered either by Emacs or within Lisp."
+ (log-event "dispatch-event: ~s~%" event)
+ (dcase event
+ ((:emacs-rex form package thread-id id)
+ (let ((thread (thread-for-evaluation connection thread-id)))
+ (cond (thread
+ (add-active-thread connection thread)
+ (send-event thread `(:emacs-rex ,form ,package ,id)))
+ (t
+ (encode-message
+ (list :invalid-rpc id
+ (format nil "Thread not found: ~s" thread-id))
+ (current-socket-io))))))
+ ((:return thread &rest args)
+ (remove-active-thread connection thread)
+ (encode-message `(:return ,@args) (current-socket-io)))
+ ((:emacs-interrupt thread-id)
+ (interrupt-worker-thread connection thread-id))
+ (((:write-string
+ :debug :debug-condition :debug-activate :debug-return :channel-send
+ :presentation-start :presentation-end
+ :new-package :new-features :ed :indentation-update
+ :eval :eval-no-wait :background-message :inspect :ping
+ :y-or-n-p :read-from-minibuffer :read-string :read-aborted :test-delay
+ :write-image)
+ &rest _)
+ (declare (ignore _))
+ (encode-message event (current-socket-io)))
+ (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
+ (send-event (find-thread thread-id) (cons (car event) args)))
+ ((:emacs-channel-send channel-id msg)
+ (let ((ch (find-channel channel-id)))
+ (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg))))
+ ((:reader-error packet condition)
+ (encode-message `(:reader-error ,packet
+ ,(safe-condition-message condition))
+ (current-socket-io)))))
+
+
+(defun send-event (thread event)
+ (log-event "send-event: ~s ~s~%" thread event)
+ (let ((c *emacs-connection*))
+ (etypecase c
+ (multithreaded-connection
+ (send thread event))
+ (singlethreaded-connection
+ (setf (sconn.event-queue c) (nconc (sconn.event-queue c) (list event)))
+ (setf (sconn.events-enqueued c) (mod (1+ (sconn.events-enqueued c))
+ most-positive-fixnum))))))
+
+(defun send-to-emacs (event)
+ "Send EVENT to Emacs."
+ ;;(log-event "send-to-emacs: ~a" event)
+ (without-slime-interrupts
+ (let ((c *emacs-connection*))
+ (etypecase c
+ (multithreaded-connection
+ (send (mconn.control-thread c) event))
+ (singlethreaded-connection
+ (dispatch-event c event)))
+ (maybe-slow-down))))
+
+
+;;;;;; Flow control
+
+;; After sending N (usually 100) messages we slow down and ping Emacs
+;; to make sure that everything we have sent so far was received.
+
+(defconstant send-counter-limit 100)
+
+(defun maybe-slow-down ()
+ (let ((counter (incf *send-counter*)))
+ (when (< send-counter-limit counter)
+ (setf *send-counter* 0)
+ (ping-pong))))
+
+(defun ping-pong ()
+ (let* ((tag (make-tag))
+ (pattern `(:emacs-pong ,tag)))
+ (send-to-emacs `(:ping ,(current-thread-id) ,tag))
+ (wait-for-event pattern)))
+
+
+(defun wait-for-event (pattern &optional timeout)
+ "Scan the event queue for PATTERN and return the event.
+If TIMEOUT is 'nil wait until a matching event is enqued.
+If TIMEOUT is 't only scan the queue without waiting.
+The second return value is t if the timeout expired before a matching
+event was found."
+ (log-event "wait-for-event: ~s ~s~%" pattern timeout)
+ (without-slime-interrupts
+ (let ((c *emacs-connection*))
+ (etypecase c
+ (multithreaded-connection
+ (receive-if (lambda (e) (event-match-p e pattern)) timeout))
+ (singlethreaded-connection
+ (wait-for-event/event-loop c pattern timeout))))))
+
+(defun wait-for-event/event-loop (connection pattern timeout)
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (let ((event (poll-for-event connection pattern)))
+ (when event (return (car event))))
+ (let ((events-enqueued (sconn.events-enqueued connection))
+ (ready (wait-for-input (list (current-socket-io)) timeout)))
+ (cond ((and timeout (not ready))
+ (return (values nil t)))
+ ((or (/= events-enqueued (sconn.events-enqueued connection))
+ (eq ready :interrupt))
+ ;; rescan event queue, interrupts may enqueue new events
+ )
+ (t
+ (assert (equal ready (list (current-socket-io))))
+ (dispatch-event connection
+ (decode-message (current-socket-io))))))))
+
+(defun poll-for-event (connection pattern)
+ (let* ((c connection)
+ (tail (member-if (lambda (e) (event-match-p e pattern))
+ (sconn.event-queue c))))
+ (when tail
+ (setf (sconn.event-queue c)
+ (nconc (ldiff (sconn.event-queue c) tail) (cdr tail)))
+ tail)))
+
+;;; FIXME: Make this use SWANK-MATCH.
+(defun event-match-p (event pattern)
+ (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
+ (member pattern '(nil t)))
+ (equal event pattern))
+ ((symbolp pattern) t)
+ ((consp pattern)
+ (case (car pattern)
+ ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern)))
+ (t (and (consp event)
+ (and (event-match-p (car event) (car pattern))
+ (event-match-p (cdr event) (cdr pattern)))))))
+ (t (error "Invalid pattern: ~S" pattern))))
+
+
+
+(defun spawn-threads-for-connection (connection)
+ (setf (mconn.control-thread connection)
+ (spawn (lambda () (control-thread connection))
+ :name "control-thread"))
+ connection)
+
+(defun control-thread (connection)
+ (with-struct* (mconn. @ connection)
+ (setf (@ control-thread) (current-thread))
+ (setf (@ reader-thread) (spawn (lambda () (read-loop connection))
+ :name "reader-thread"))
+ (setf (@ indentation-cache-thread)
+ (spawn (lambda () (indentation-cache-loop connection))
+ :name "swank-indentation-cache-thread"))
+ (dispatch-loop connection)))
+
+(defun cleanup-connection-threads (connection)
+ (let* ((c connection)
+ (threads (list (mconn.repl-thread c)
+ (mconn.reader-thread c)
+ (mconn.control-thread c)
+ (mconn.auto-flush-thread c)
+ (mconn.indentation-cache-thread c))))
+ (dolist (thread threads)
+ (when (and thread
+ (thread-alive-p thread)
+ (not (equal (current-thread) thread)))
+ (kill-thread thread)))))
+
+;;;;;; Signal driven IO
+
+(defun install-sigio-handler (connection)
+ (add-sigio-handler (connection.socket-io connection)
+ (lambda () (process-io-interrupt connection)))
+ (handle-requests connection t))
+
+(defvar *io-interupt-level* 0)
+
+(defun process-io-interrupt (connection)
+ (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*)
+ (let ((*io-interupt-level* (1+ *io-interupt-level*)))
+ (invoke-or-queue-interrupt
+ (lambda () (handle-requests connection t))))
+ (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*))
+
+(defun deinstall-sigio-handler (connection)
+ (log-event "deinstall-sigio-handler...~%")
+ (remove-sigio-handlers (connection.socket-io connection))
+ (log-event "deinstall-sigio-handler...done~%"))
+
+;;;;;; SERVE-EVENT based IO
+
+(defun install-fd-handler (connection)
+ (add-fd-handler (connection.socket-io connection)
+ (lambda () (handle-requests connection t)))
+ (setf (sconn.saved-sigint-handler connection)
+ (install-sigint-handler
+ (lambda ()
+ (invoke-or-queue-interrupt
+ (lambda () (dispatch-interrupt-event connection))))))
+ (handle-requests connection t))
+
+(defun dispatch-interrupt-event (connection)
+ (with-connection (connection)
+ (dispatch-event connection `(:emacs-interrupt ,(current-thread-id)))))
+
+(defun deinstall-fd-handler (connection)
+ (log-event "deinstall-fd-handler~%")
+ (remove-fd-handlers (connection.socket-io connection))
+ (install-sigint-handler (sconn.saved-sigint-handler connection)))
+
+;;;;;; Simple sequential IO
+
+(defun simple-serve-requests (connection)
+ (unwind-protect
+ (with-connection (connection)
+ (call-with-user-break-handler
+ (lambda ()
+ (invoke-or-queue-interrupt
+ (lambda () (dispatch-interrupt-event connection))))
+ (lambda ()
+ (with-simple-restart (close-connection "Close SLIME connection.")
+ (let* ((stdin (real-input-stream *standard-input*))
+ (*standard-input* (make-repl-input-stream connection
+ stdin)))
+ (tagbody toplevel
+ (with-top-level-restart (connection (go toplevel))
+ (simple-repl))))))))
+ (close-connection connection nil (safe-backtrace))))
+
+;; this is signalled when our custom stream thinks the end-of-file is reached.
+;; (not when the end-of-file on the socket is reached)
+(define-condition end-of-repl-input (end-of-file) ())
+
+(defun simple-repl ()
+ (loop
+ (format t "~a> " (package-string-for-prompt *package*))
+ (force-output)
+ (let ((form (handler-case (read)
+ (end-of-repl-input () (return)))))
+ (let ((- form)
+ (values (multiple-value-list (eval form))))
+ (setq *** ** ** * * (car values)
+ /// // // / / values
+ +++ ++ ++ + + form)
+ (cond ((null values) (format t "; No values~&"))
+ (t (mapc (lambda (v) (format t "~s~&" v)) values)))))))
+
+(defun make-repl-input-stream (connection stdin)
+ (make-input-stream
+ (lambda () (repl-input-stream-read connection stdin))))
+
+(defun repl-input-stream-read (connection stdin)
+ (loop
+ (let* ((socket (connection.socket-io connection))
+ (inputs (list socket stdin))
+ (ready (wait-for-input inputs)))
+ (cond ((eq ready :interrupt)
+ (check-slime-interrupts))
+ ((member socket ready)
+ ;; A Slime request from Emacs is pending; make sure to
+ ;; redirect IO to the REPL buffer.
+ (with-simple-restart (process-input "Continue reading input.")
+ (let ((*sldb-quit-restart* (find-restart 'process-input)))
+ (with-io-redirection (connection)
+ (handle-requests connection t)))))
+ ((member stdin ready)
+ ;; User typed something into the *inferior-lisp* buffer,
+ ;; so do not redirect.
+ (return (read-non-blocking stdin)))
+ (t (assert (null ready)))))))
+
+(defun read-non-blocking (stream)
+ (with-output-to-string (str)
+ (handler-case
+ (loop (let ((c (read-char-no-hang stream)))
+ (unless c (return))
+ (write-char c str)))
+ (end-of-file () (error 'end-of-repl-input :stream stream)))))
+
+
+;;; Channels
+
+;; FIXME: should be per connection not global.
+(defvar *channels* '())
+(defvar *channel-counter* 0)
+
+(defclass channel ()
+ ((id :reader channel-id)
+ (thread :initarg :thread :initform (current-thread) :reader channel-thread)
+ (name :initarg :name :initform nil)))
+
+(defmethod initialize-instance :after ((ch channel) &key)
+ (with-slots (id) ch
+ (setf id (incf *channel-counter*))
+ (push (cons id ch) *channels*)))
+
+(defmethod print-object ((c channel) stream)
+ (print-unreadable-object (c stream :type t)
+ (with-slots (id name) c
+ (format stream "~d ~a" id name))))
+
+(defun find-channel (id)
+ (cdr (assoc id *channels*)))
+
+(defgeneric channel-send (channel selector args))
+
+(defmacro define-channel-method (selector (channel &rest args) &body body)
+ `(defmethod channel-send (,channel (selector (eql ',selector)) args)
+ (destructuring-bind ,args args
+ . ,body)))
+
+(defun send-to-remote-channel (channel-id msg)
+ (send-to-emacs `(:channel-send ,channel-id ,msg)))
+
+
+
+(defvar *slime-features* nil
+ "The feature list that has been sent to Emacs.")
+
+(defun send-oob-to-emacs (object)
+ (send-to-emacs object))
+
+;; FIXME: belongs to swank-repl.lisp
+(defun force-user-output ()
+ (force-output (connection.user-io *emacs-connection*)))
+
+(add-hook *pre-reply-hook* 'force-user-output)
+
+;; FIXME: belongs to swank-repl.lisp
+(defun clear-user-input ()
+ (clear-input (connection.user-input *emacs-connection*)))
+
+;; FIXME: not thread save.
+(defvar *tag-counter* 0)
+
+(defun make-tag ()
+ (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))
+
+(defun y-or-n-p-in-emacs (format-string &rest arguments)
+ "Like y-or-n-p, but ask in the Emacs minibuffer."
+ (let ((tag (make-tag))
+ (question (apply #'format nil format-string arguments)))
+ (force-output)
+ (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question))
+ (third (wait-for-event `(:emacs-return ,tag result)))))
+
+(defun read-from-minibuffer-in-emacs (prompt &optional initial-value)
+ "Ask user a question in Emacs' minibuffer. Returns \"\" when user
+entered nothing, returns NIL when user pressed C-g."
+ (check-type prompt string) (check-type initial-value (or null string))
+ (let ((tag (make-tag)))
+ (force-output)
+ (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag
+ ,prompt ,initial-value))
+ (third (wait-for-event `(:emacs-return ,tag result)))))
+
+(defstruct (unredable-result
+ (:constructor make-unredable-result (string))
+ (:copier nil)
+ (:print-object
+ (lambda (object stream)
+ (print-unreadable-object (object stream :type t)
+ (princ (unredable-result-string object) stream)))))
+ string)
+
+(defun process-form-for-emacs (form)
+ "Returns a string which emacs will read as equivalent to
+FORM. FORM can contain lists, strings, characters, symbols and
+numbers.
+
+Characters are converted emacs' ?<char> notaion, strings are left
+as they are (except for espacing any nested \" chars, numbers are
+printed in base 10 and symbols are printed as their symbol-name
+converted to lower case."
+ (etypecase form
+ (string (format nil "~S" form))
+ (cons (format nil "(~A . ~A)"
+ (process-form-for-emacs (car form))
+ (process-form-for-emacs (cdr form))))
+ (character (format nil "?~C" form))
+ (symbol (concatenate 'string (when (eq (symbol-package form)
+ #.(find-package "KEYWORD"))
+ ":")
+ (string-downcase (symbol-name form))))
+ (number (let ((*print-base* 10))
+ (princ-to-string form)))))
+
+(defun eval-in-emacs (form &optional nowait)
+ "Eval FORM in Emacs.
+`slime-enable-evaluate-in-emacs' should be set to T on the Emacs side."
+ (cond (nowait
+ (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
+ (t
+ (force-output)
+ (let ((tag (make-tag)))
+ (send-to-emacs `(:eval ,(current-thread-id) ,tag
+ ,(process-form-for-emacs form)))
+ (let ((value (caddr (wait-for-event `(:emacs-return ,tag result)))))
+ (dcase value
+ ((:unreadable value) (make-unredable-result value))
+ ((:ok value) value)
+ ((:error kind . data) (error "~a: ~{~a~}" kind data))
+ ((:abort) (abort))))))))
+
+(defvar *swank-wire-protocol-version* nil
+ "The version of the swank/slime communication protocol.")
+
+(defslimefun connection-info ()
+ "Return a key-value list of the form:
+\(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
+PID: is the process-id of Lisp process (or nil, depending on the STYLE)
+STYLE: the communication style
+LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
+FEATURES: a list of keywords
+PACKAGE: a list (&key NAME PROMPT)
+VERSION: the protocol version"
+ (let ((c *emacs-connection*))
+ (setq *slime-features* *features*)
+ `(:pid ,(getpid) :style ,(connection.communication-style c)
+ :encoding (:coding-systems
+ ,(loop for cs in '("utf-8-unix" "iso-latin-1-unix")
+ when (find-external-format cs) collect cs))
+ :lisp-implementation (:type ,(lisp-implementation-type)
+ :name ,(lisp-implementation-type-name)
+ :version ,(lisp-implementation-version)
+ :program ,(lisp-implementation-program))
+ :machine (:instance ,(machine-instance)
+ :type ,(machine-type)
+ :version ,(machine-version))
+ :features ,(features-for-emacs)
+ :modules ,*modules*
+ :package (:name ,(package-name *package*)
+ :prompt ,(package-string-for-prompt *package*))
+ :version ,*swank-wire-protocol-version*)))
+
+(defun debug-on-swank-error ()
+ (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*))
+ *debug-on-swank-protocol-error*)
+
+(defun (setf debug-on-swank-error) (new-value)
+ (setf *debug-on-swank-protocol-error* new-value)
+ (setf *debug-swank-backend* new-value))
+
+(defslimefun toggle-debug-on-swank-error ()
+ (setf (debug-on-swank-error) (not (debug-on-swank-error))))
+
+
+;;;; Reading and printing
+
+(define-special *buffer-package*
+ "Package corresponding to slime-buffer-package.
+
+EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
+buffer are best read in this package. See also FROM-STRING and TO-STRING.")
+
+(define-special *buffer-readtable*
+ "Readtable associated with the current buffer")
+
+(defmacro with-buffer-syntax ((&optional package) &body body)
+ "Execute BODY with appropriate *package* and *readtable* bindings.
+
+This should be used for code that is conceptionally executed in an
+Emacs buffer."
+ `(call-with-buffer-syntax ,package (lambda () ,@body)))
+
+(defun call-with-buffer-syntax (package fun)
+ (let ((*package* (if package
+ (guess-buffer-package package)
+ *buffer-package*)))
+ ;; Don't shadow *readtable* unnecessarily because that prevents
+ ;; the user from assigning to it.
+ (if (eq *readtable* *buffer-readtable*)
+ (call-with-syntax-hooks fun)
+ (let ((*readtable* *buffer-readtable*))
+ (call-with-syntax-hooks fun)))))
+
+(defmacro without-printing-errors ((&key object stream
+ (msg "<<error printing object>>"))
+ &body body)
+ "Catches errors during evaluation of BODY and prints MSG instead."
+ `(handler-case (progn ,@body)
+ (serious-condition ()
+ ,(cond ((and stream object)
+ (let ((gstream (gensym "STREAM+")))
+ `(let ((,gstream ,stream))
+ (print-unreadable-object (,object ,gstream :type t
+ :identity t)
+ (write-string ,msg ,gstream)))))
+ (stream
+ `(write-string ,msg ,stream))
+ (object
+ `(with-output-to-string (s)
+ (print-unreadable-object (,object s :type t :identity t)
+ (write-string ,msg s))))
+ (t msg)))))
+
+(defun to-string (object)
+ "Write OBJECT in the *BUFFER-PACKAGE*.
+The result may not be readable. Handles problems with PRINT-OBJECT methods
+gracefully."
+ (with-buffer-syntax ()
+ (let ((*print-readably* nil))
+ (without-printing-errors (:object object :stream nil)
+ (prin1-to-string object)))))
+
+(defun from-string (string)
+ "Read string in the *BUFFER-PACKAGE*"
+ (with-buffer-syntax ()
+ (let ((*read-suppress* nil))
+ (values (read-from-string string)))))
+
+(defun parse-string (string package)
+ "Read STRING in PACKAGE."
+ (with-buffer-syntax (package)
+ (let ((*read-suppress* nil))
+ (read-from-string string))))
+
+;; FIXME: deal with #\| etc. hard to do portably.
+(defun tokenize-symbol (string)
+ "STRING is interpreted as the string representation of a symbol
+and is tokenized accordingly. The result is returned in three
+values: The package identifier part, the actual symbol identifier
+part, and a flag if the STRING represents a symbol that is
+internal to the package identifier part. (Notice that the flag is
+also true with an empty package identifier part, as the STRING is
+considered to represent a symbol internal to some current package.)"
+ (let ((package (let ((pos (position #\: string)))
+ (if pos (subseq string 0 pos) nil)))
+ (symbol (let ((pos (position #\: string :from-end t)))
+ (if pos (subseq string (1+ pos)) string)))
+ (internp (not (= (count #\: string) 1))))
+ (values symbol package internp)))
+
+(defun tokenize-symbol-thoroughly (string)
+ "This version of TOKENIZE-SYMBOL handles escape characters."
+ (let ((package nil)
+ (token (make-array (length string) :element-type 'character
+ :fill-pointer 0))
+ (backslash nil)
+ (vertical nil)
+ (internp nil))
+ (loop for char across string do
+ (cond
+ (backslash
+ (vector-push-extend char token)
+ (setq backslash nil))
+ ((char= char #\\) ; Quotes next character, even within |...|
+ (setq backslash t))
+ ((char= char #\|)
+ (setq vertical (not vertical)))
+ (vertical
+ (vector-push-extend char token))
+ ((char= char #\:)
+ (cond ((and package internp)
+ (return-from tokenize-symbol-thoroughly))
+ (package
+ (setq internp t))
+ (t
+ (setq package token
+ token (make-array (length string)
+ :element-type 'character
+ :fill-pointer 0)))))
+ (t
+ (vector-push-extend (casify-char char) token))))
+ (unless vertical
+ (values token package (or (not package) internp)))))
+
+(defun untokenize-symbol (package-name internal-p symbol-name)
+ "The inverse of TOKENIZE-SYMBOL.
+
+ (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
+ (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
+ (untokenize-symbol nil nil \"foo\") ==> \"foo\"
+"
+ (cond ((not package-name) symbol-name)
+ (internal-p (cat package-name "::" symbol-name))
+ (t (cat package-name ":" symbol-name))))
+
+(defun casify-char (char)
+ "Convert CHAR accoring to readtable-case."
+ (ecase (readtable-case *readtable*)
+ (:preserve char)
+ (:upcase (char-upcase char))
+ (:downcase (char-downcase char))
+ (:invert (if (upper-case-p char)
+ (char-downcase char)
+ (char-upcase char)))))
+
+
+(defun find-symbol-with-status (symbol-name status
+ &optional (package *package*))
+ (multiple-value-bind (symbol flag) (find-symbol symbol-name package)
+ (if (and flag (eq flag status))
+ (values symbol flag)
+ (values nil nil))))
+
+(defun parse-symbol (string &optional (package *package*))
+ "Find the symbol named STRING.
+Return the symbol and a flag indicating whether the symbols was found."
+ (multiple-value-bind (sname pname internalp)
+ (tokenize-symbol-thoroughly string)
+ (when sname
+ (let ((package (cond ((string= pname "") keyword-package)
+ (pname (find-package pname))
+ (t package))))
+ (if package
+ (multiple-value-bind (symbol flag)
+ (if internalp
+ (find-symbol sname package)
+ (find-symbol-with-status sname ':external package))
+ (values symbol flag sname package))
+ (values nil nil nil nil))))))
+
+(defun parse-symbol-or-lose (string &optional (package *package*))
+ (multiple-value-bind (symbol status) (parse-symbol string package)
+ (if status
+ (values symbol status)
+ (error "Unknown symbol: ~A [in ~A]" string package))))
+
+(defun parse-package (string)
+ "Find the package named STRING.
+Return the package or nil."
+ ;; STRING comes usually from a (in-package STRING) form.
+ (ignore-errors
+ (find-package (let ((*package* *swank-io-package*))
+ (read-from-string string)))))
+
+(defun unparse-name (string)
+ "Print the name STRING according to the current printer settings."
+ ;; this is intended for package or symbol names
+ (subseq (prin1-to-string (make-symbol string)) 2))
+
+(defun guess-package (string)
+ "Guess which package corresponds to STRING.
+Return nil if no package matches."
+ (when string
+ (or (find-package string)
+ (parse-package string)
+ (if (find #\! string) ; for SBCL
+ (guess-package (substitute #\- #\! string))))))
+
+(defvar *readtable-alist* (default-readtable-alist)
+ "An alist mapping package names to readtables.")
+
+(defun guess-buffer-readtable (package-name)
+ (let ((package (guess-package package-name)))
+ (or (and package
+ (cdr (assoc (package-name package) *readtable-alist*
+ :test #'string=)))
+ *readtable*)))
+
+
+;;;; Evaluation
+
+(defvar *pending-continuations* '()
+ "List of continuations for Emacs. (thread local)")
+
+(defun guess-buffer-package (string)
+ "Return a package for STRING.
+Fall back to the current if no such package exists."
+ (or (and string (guess-package string))
+ *package*))
+
+(defun eval-for-emacs (form buffer-package id)
+ "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
+Return the result to the continuation ID.
+Errors are trapped and invoke our debugger."
+ (let (ok result condition)
+ (unwind-protect
+ (let ((*buffer-package* (guess-buffer-package buffer-package))
+ (*buffer-readtable* (guess-buffer-readtable buffer-package))
+ (*pending-continuations* (cons id *pending-continuations*)))
+ (check-type *buffer-package* package)
+ (check-type *buffer-readtable* readtable)
+ ;; APPLY would be cleaner than EVAL.
+ ;; (setq result (apply (car form) (cdr form)))
+ (handler-bind ((t (lambda (c) (setf condition c))))
+ (setq result (with-slime-interrupts (eval form))))
+ (run-hook *pre-reply-hook*)
+ (setq ok t))
+ (send-to-emacs `(:return ,(current-thread)
+ ,(if ok
+ `(:ok ,result)
+ `(:abort ,(prin1-to-string condition)))
+ ,id)))))
+
+(defvar *echo-area-prefix* "=> "
+ "A prefix that `format-values-for-echo-area' should use.")
+
+(defun format-values-for-echo-area (values)
+ (with-buffer-syntax ()
+ (let ((*print-readably* nil))
+ (cond ((null values) "; No value")
+ ((and (integerp (car values)) (null (cdr values)))
+ (let ((i (car values)))
+ (format nil "~A~D (~a bit~:p, #x~X, #o~O, #b~B)"
+ *echo-area-prefix*
+ i (integer-length i) i i i)))
+ ((and (typep (car values) 'ratio)
+ (null (cdr values))
+ (ignore-errors
+ ;; The ratio may be to large to be represented as a single float
+ (format nil "~A~D (~:*~f)"
+ *echo-area-prefix*
+ (car values)))))
+ (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
+
+(defmacro values-to-string (values)
+ `(format-values-for-echo-area (multiple-value-list ,values)))
+
+(defslimefun interactive-eval (string)
+ (with-buffer-syntax ()
+ (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
+ (let ((values (multiple-value-list (eval (from-string string)))))
+ (finish-output)
+ (format-values-for-echo-area values)))))
+
+(defslimefun eval-and-grab-output (string)
+ (with-buffer-syntax ()
+ (with-retry-restart (:msg "Retry SLIME evaluation request.")
+ (let* ((s (make-string-output-stream))
+ (*standard-output* s)
+ (values (multiple-value-list (eval (from-string string)))))
+ (list (get-output-stream-string s)
+ (format nil "~{~S~^~%~}" values))))))
+
+(defun eval-region (string)
+ "Evaluate STRING.
+Return the results of the last form as a list and as secondary value the
+last form."
+ (with-input-from-string (stream string)
+ (let (- values)
+ (loop
+ (let ((form (read stream nil stream)))
+ (when (eq form stream)
+ (finish-output)
+ (return (values values -)))
+ (setq - form)
+ (setq values (multiple-value-list (eval form)))
+ (finish-output))))))
+
+(defslimefun interactive-eval-region (string)
+ (with-buffer-syntax ()
+ (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
+ (format-values-for-echo-area (eval-region string)))))
+
+(defslimefun re-evaluate-defvar (form)
+ (with-buffer-syntax ()
+ (with-retry-restart (:msg "Retry SLIME evaluation request.")
+ (let ((form (read-from-string form)))
+ (destructuring-bind (dv name &optional value doc) form
+ (declare (ignore value doc))
+ (assert (eq dv 'defvar))
+ (makunbound name)
+ (prin1-to-string (eval form)))))))
+
+(defvar *swank-pprint-bindings*
+ `((*print-pretty* . t)
+ (*print-level* . nil)
+ (*print-length* . nil)
+ (*print-circle* . t)
+ (*print-gensym* . t)
+ (*print-readably* . nil))
+ "A list of variables bindings during pretty printing.
+Used by pprint-eval.")
+
+(defun swank-pprint (values)
+ "Bind some printer variables and pretty print each object in VALUES."
+ (with-buffer-syntax ()
+ (with-bindings *swank-pprint-bindings*
+ (cond ((null values) "; No value")
+ (t (with-output-to-string (*standard-output*)
+ (dolist (o values)
+ (pprint o)
+ (terpri))))))))
+
+(defslimefun pprint-eval (string)
+ (with-buffer-syntax ()
+ (let* ((s (make-string-output-stream))
+ (values
+ (let ((*standard-output* s)
+ (*trace-output* s))
+ (multiple-value-list (eval (read-from-string string))))))
+ (cat (get-output-stream-string s)
+ (swank-pprint values)))))
+
+(defslimefun set-package (name)
+ "Set *package* to the package named NAME.
+Return the full package-name and the string to use in the prompt."
+ (let ((p (guess-package name)))
+ (assert (packagep p) nil "Package ~a doesn't exist." name)
+ (setq *package* p)
+ (list (package-name p) (package-string-for-prompt p))))
+
+(defun cat (&rest strings)
+ "Concatenate all arguments and make the result a string."
+ (with-output-to-string (out)
+ (dolist (s strings)
+ (etypecase s
+ (string (write-string s out))
+ (character (write-char s out))))))
+
+(defun truncate-string (string width &optional ellipsis)
+ (let ((len (length string)))
+ (cond ((< len width) string)
+ (ellipsis (cat (subseq string 0 width) ellipsis))
+ (t (subseq string 0 width)))))
+
+(defun call/truncated-output-to-string (length function
+ &optional (ellipsis ".."))
+ "Call FUNCTION with a new stream, return the output written to the stream.
+If FUNCTION tries to write more than LENGTH characters, it will be
+aborted and return immediately with the output written so far."
+ (let ((buffer (make-string (+ length (length ellipsis))))
+ (fill-pointer 0))
+ (block buffer-full
+ (flet ((write-output (string)
+ (let* ((free (- length fill-pointer))
+ (count (min free (length string))))
+ (replace buffer string :start1 fill-pointer :end2 count)
+ (incf fill-pointer count)
+ (when (> (length string) free)
+ (replace buffer ellipsis :start1 fill-pointer)
+ (return-from buffer-full buffer)))))
+ (let ((stream (make-output-stream #'write-output)))
+ (funcall function stream)
+ (finish-output stream)
+ (subseq buffer 0 fill-pointer))))))
+
+(defmacro with-string-stream ((var &key length bindings)
+ &body body)
+ (cond ((and (not bindings) (not length))
+ `(with-output-to-string (,var) . ,body))
+ ((not bindings)
+ `(call/truncated-output-to-string
+ ,length (lambda (,var) . ,body)))
+ (t
+ `(with-bindings ,bindings
+ (with-string-stream (,var :length ,length)
+ . ,body)))))
+
+(defun to-line (object &optional width)
+ "Print OBJECT to a single line. Return the string."
+ (let ((width (or width 512)))
+ (without-printing-errors (:object object :stream nil)
+ (with-string-stream (stream :length width)
+ (write object :stream stream :right-margin width :lines 1)))))
+
+(defun escape-string (string stream &key length (map '((#\" . "\\\"")
+ (#\\ . "\\\\"))))
+ "Write STRING to STREAM surronded by double-quotes.
+LENGTH -- if non-nil truncate output after LENGTH chars.
+MAP -- rewrite the chars in STRING according to this alist."
+ (let ((limit (or length array-dimension-limit)))
+ (write-char #\" stream)
+ (loop for c across string
+ for i from 0 do
+ (when (= i limit)
+ (write-string "..." stream)
+ (return))
+ (let ((probe (assoc c map)))
+ (cond (probe (write-string (cdr probe) stream))
+ (t (write-char c stream)))))
+ (write-char #\" stream)))
+
+
+;;;; Prompt
+
+;; FIXME: do we really need 45 lines of code just to figure out the
+;; prompt?
+
+(defvar *canonical-package-nicknames*
+ `((:common-lisp-user . :cl-user))
+ "Canonical package names to use instead of shortest name/nickname.")
+
+(defvar *auto-abbreviate-dotted-packages* t
+ "Abbreviate dotted package names to their last component if T.")
+
+(defun package-string-for-prompt (package)
+ "Return the shortest nickname (or canonical name) of PACKAGE."
+ (unparse-name
+ (or (canonical-package-nickname package)
+ (auto-abbreviated-package-name package)
+ (shortest-package-nickname package))))
+
+(defun canonical-package-nickname (package)
+ "Return the canonical package nickname, if any, of PACKAGE."
+ (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
+ :test #'string=))))
+ (and name (string name))))
+
+(defun auto-abbreviated-package-name (package)
+ "Return an abbreviated 'name' for PACKAGE.
+
+N.B. this is not an actual package name or nickname."
+ (when *auto-abbreviate-dotted-packages*
+ (loop with package-name = (package-name package)
+ with offset = nil
+ do (let ((last-dot-pos (position #\. package-name :end offset
+ :from-end t)))
+ (unless last-dot-pos
+ (return nil))
+ ;; If a dot chunk contains only numbers, that chunk most
+ ;; likely represents a version number; so we collect the
+ ;; next chunks, too, until we find one with meat.
+ (let ((name (subseq package-name (1+ last-dot-pos) offset)))
+ (if (notevery #'digit-char-p name)
+ (return (subseq package-name (1+ last-dot-pos)))
+ (setq offset last-dot-pos)))))))
+
+(defun shortest-package-nickname (package)
+ "Return the shortest nickname of PACKAGE."
+ (loop for name in (cons (package-name package) (package-nicknames package))
+ for shortest = name then (if (< (length name) (length shortest))
+ name
+ shortest)
+ finally (return shortest)))
+
+
+
+(defslimefun ed-in-emacs (&optional what)
+ "Edit WHAT in Emacs.
+
+WHAT can be:
+ A pathname or a string,
+ A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION),
+ A function name (symbol or cons),
+ NIL. "
+ (flet ((canonicalize-filename (filename)
+ (pathname-to-filename (or (probe-file filename) filename))))
+ (let ((target
+ (etypecase what
+ (null nil)
+ ((or string pathname)
+ `(:filename ,(canonicalize-filename what)))
+ ((cons (or string pathname) *)
+ `(:filename ,(canonicalize-filename (car what)) ,@(cdr what)))
+ ((or symbol cons)
+ `(:function-name ,(prin1-to-string what))))))
+ (cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
+ ((default-connection)
+ (with-connection ((default-connection))
+ (send-oob-to-emacs `(:ed ,target))))
+ (t (error "No connection"))))))
+
+(defslimefun inspect-in-emacs (what &key wait)
+ "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the
+inspector has been closed in Emacs."
+ (flet ((send-it ()
+ (let ((tag (when wait (make-tag)))
+ (thread (when wait (current-thread-id))))
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (send-oob-to-emacs `(:inspect ,(inspect-object what)
+ ,thread
+ ,tag)))
+ (when wait
+ (wait-for-event `(:emacs-return ,tag result))))))
+ (cond
+ (*emacs-connection*
+ (send-it))
+ ((default-connection)
+ (with-connection ((default-connection))
+ (send-it))))
+ what))
+
+(defslimefun value-for-editing (form)
+ "Return a readable value of FORM for editing in Emacs.
+FORM is expected, but not required, to be SETF'able."
+ ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
+ (with-buffer-syntax ()
+ (let* ((value (eval (read-from-string form)))
+ (*print-length* nil))
+ (prin1-to-string value))))
+
+(defslimefun commit-edited-value (form value)
+ "Set the value of a setf'able FORM to VALUE.
+FORM and VALUE are both strings from Emacs."
+ (with-buffer-syntax ()
+ (eval `(setf ,(read-from-string form)
+ ,(read-from-string (concatenate 'string "`" value))))
+ t))
+
+(defun background-message (format-string &rest args)
+ "Display a message in Emacs' echo area.
+
+Use this function for informative messages only. The message may even
+be dropped if we are too busy with other things."
+ (when *emacs-connection*
+ (send-to-emacs `(:background-message
+ ,(apply #'format nil format-string args)))))
+
+;; This is only used by the test suite.
+(defun sleep-for (seconds)
+ "Sleep for at least SECONDS seconds.
+This is just like cl:sleep but guarantees to sleep
+at least SECONDS."
+ (let* ((start (get-internal-real-time))
+ (end (+ start
+ (* seconds internal-time-units-per-second))))
+ (loop
+ (let ((now (get-internal-real-time)))
+ (cond ((< end now) (return))
+ (t (sleep (/ (- end now)
+ internal-time-units-per-second))))))))
+
+
+;;;; Debugger
+
+(defun invoke-slime-debugger (condition)
+ "Sends a message to Emacs declaring that the debugger has been entered,
+then waits to handle further requests from Emacs. Eventually returns
+after Emacs causes a restart to be invoked."
+ (without-slime-interrupts
+ (cond (*emacs-connection*
+ (debug-in-emacs condition))
+ ((default-connection)
+ (with-connection ((default-connection))
+ (debug-in-emacs condition))))))
+
+(define-condition invoke-default-debugger () ())
+
+(defun swank-debugger-hook (condition hook)
+ "Debugger function for binding *DEBUGGER-HOOK*."
+ (declare (ignore hook))
+ (handler-case
+ (call-with-debugger-hook #'swank-debugger-hook
+ (lambda () (invoke-slime-debugger condition)))
+ (invoke-default-debugger ()
+ (invoke-default-debugger condition))))
+
+(defun invoke-default-debugger (condition)
+ (call-with-debugger-hook nil (lambda () (invoke-debugger condition))))
+
+(defvar *global-debugger* t
+ "Non-nil means the Swank debugger hook will be installed globally.")
+
+(add-hook *new-connection-hook* 'install-debugger)
+(defun install-debugger (connection)
+ (declare (ignore connection))
+ (when *global-debugger*
+ (install-debugger-globally #'swank-debugger-hook)))
+
+;;;;; Debugger loop
+;;;
+;;; These variables are dynamically bound during debugging.
+;;;
+(defvar *swank-debugger-condition* nil
+ "The condition being debugged.")
+
+(defvar *sldb-level* 0
+ "The current level of recursive debugging.")
+
+(defvar *sldb-initial-frames* 20
+ "The initial number of backtrace frames to send to Emacs.")
+
+(defvar *sldb-restarts* nil
+ "The list of currenlty active restarts.")
+
+(defvar *sldb-stepping-p* nil
+ "True during execution of a step command.")
+
+(defun debug-in-emacs (condition)
+ (let ((*swank-debugger-condition* condition)
+ (*sldb-restarts* (compute-restarts condition))
+ (*sldb-quit-restart* (and *sldb-quit-restart*
+ (find-restart *sldb-quit-restart*)))
+ (*package* (or (and (boundp '*buffer-package*)
+ (symbol-value '*buffer-package*))
+ *package*))
+ (*sldb-level* (1+ *sldb-level*))
+ (*sldb-stepping-p* nil))
+ (force-user-output)
+ (call-with-debugging-environment
+ (lambda ()
+ (sldb-loop *sldb-level*)))))
+
+(defun sldb-loop (level)
+ (unwind-protect
+ (loop
+ (with-simple-restart (abort "Return to sldb level ~D." level)
+ (send-to-emacs
+ (list* :debug (current-thread-id) level
+ (debugger-info-for-emacs 0 *sldb-initial-frames*)))
+ (send-to-emacs
+ (list :debug-activate (current-thread-id) level nil))
+ (loop
+ (handler-case
+ (dcase (wait-for-event
+ `(or (:emacs-rex . _)
+ (:sldb-return ,(1+ level))))
+ ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
+ ((:sldb-return _) (declare (ignore _)) (return nil)))
+ (sldb-condition (c)
+ (handle-sldb-condition c))))))
+ (send-to-emacs `(:debug-return
+ ,(current-thread-id) ,level ,*sldb-stepping-p*))
+ (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue
+ (when (> level 1)
+ (send-event (current-thread) `(:sldb-return ,level)))))
+
+(defun handle-sldb-condition (condition)
+ "Handle an internal debugger condition.
+Rather than recursively debug the debugger (a dangerous idea!), these
+conditions are simply reported."
+ (let ((real-condition (original-condition condition)))
+ (send-to-emacs `(:debug-condition ,(current-thread-id)
+ ,(princ-to-string real-condition)))))
+
+(defun %%condition-message (condition)
+ (let ((limit (ash 1 16)))
+ (with-string-stream (stream :length limit)
+ (handler-case
+ (let ((*print-readably* nil)
+ (*print-pretty* t)
+ (*print-right-margin* 65)
+ (*print-circle* t)
+ (*print-length* (or *print-length* limit))
+ (*print-level* (or *print-level* limit))
+ (*print-lines* (or *print-lines* limit)))
+ (print-condition condition stream))
+ (serious-condition (c)
+ (ignore-errors
+ (with-standard-io-syntax
+ (let ((*print-readably* nil))
+ (format stream "~&Error (~a) during printing: " (type-of c))
+ (print-unreadable-object (condition stream :type t
+ :identity t))))))))))
+
+(defun %condition-message (condition)
+ (string-trim #(#\newline #\space #\tab)
+ (%%condition-message condition)))
+
+(defvar *sldb-condition-printer* #'%condition-message
+ "Function called to print a condition to an SLDB buffer.")
+
+(defun safe-condition-message (condition)
+ "Print condition to a string, handling any errors during printing."
+ (funcall *sldb-condition-printer* condition))
+
+(defun debugger-condition-for-emacs ()
+ (list (safe-condition-message *swank-debugger-condition*)
+ (format nil " [Condition of type ~S]"
+ (type-of *swank-debugger-condition*))
+ (condition-extras *swank-debugger-condition*)))
+
+(defun format-restarts-for-emacs ()
+ "Return a list of restarts for *swank-debugger-condition* in a
+format suitable for Emacs."
+ (let ((*print-right-margin* most-positive-fixnum))
+ (loop for restart in *sldb-restarts* collect
+ (list (format nil "~:[~;*~]~a"
+ (eq restart *sldb-quit-restart*)
+ (restart-name restart))
+ (with-output-to-string (stream)
+ (without-printing-errors (:object restart
+ :stream stream
+ :msg "<<error printing restart>>")
+ (princ restart stream)))))))
+
+;;;;; SLDB entry points
+
+(defslimefun sldb-break-with-default-debugger (dont-unwind)
+ "Invoke the default debugger."
+ (cond (dont-unwind
+ (invoke-default-debugger *swank-debugger-condition*))
+ (t
+ (signal 'invoke-default-debugger))))
+
+(defslimefun backtrace (start end)
+ "Return a list ((I FRAME PLIST) ...) of frames from START to END.
+
+I is an integer, and can be used to reference the corresponding frame
+from Emacs; FRAME is a string representation of an implementation's
+frame."
+ (loop for frame in (compute-backtrace start end)
+ for i from start collect
+ (list* i (frame-to-string frame)
+ (ecase (frame-restartable-p frame)
+ ((nil) nil)
+ ((t) `((:restartable t)))))))
+
+(defun frame-to-string (frame)
+ (with-string-stream (stream :length (* (or *print-lines* 1)
+ (or *print-right-margin* 100))
+ :bindings *backtrace-printer-bindings*)
+ (handler-case (print-frame frame stream)
+ (serious-condition ()
+ (format stream "[error printing frame]")))))
+
+(defslimefun debugger-info-for-emacs (start end)
+ "Return debugger state, with stack frames from START to END.
+The result is a list:
+ (condition ({restart}*) ({stack-frame}*) (cont*))
+where
+ condition ::= (description type [extra])
+ restart ::= (name description)
+ stack-frame ::= (number description [plist])
+ extra ::= (:references and other random things)
+ cont ::= continutation
+ plist ::= (:restartable {nil | t | :unknown})
+
+condition---a pair of strings: message, and type. If show-source is
+not nil it is a frame number for which the source should be displayed.
+
+restart---a pair of strings: restart name, and description.
+
+stack-frame---a number from zero (the top), and a printed
+representation of the frame's call.
+
+continutation---the id of a pending Emacs continuation.
+
+Below is an example return value. In this case the condition was a
+division by zero (multi-line description), and only one frame is being
+fetched (start=0, end=1).
+
+ ((\"Arithmetic error DIVISION-BY-ZERO signalled.
+Operation was KERNEL::DIVISION, operands (1 0).\"
+ \"[Condition of type DIVISION-BY-ZERO]\")
+ ((\"ABORT\" \"Return to Slime toplevel.\")
+ (\"ABORT\" \"Return to Top-Level.\"))
+ ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil)))
+ (4))"
+ (list (debugger-condition-for-emacs)
+ (format-restarts-for-emacs)
+ (backtrace start end)
+ *pending-continuations*))
+
+(defun nth-restart (index)
+ (nth index *sldb-restarts*))
+
+(defslimefun invoke-nth-restart (index)
+ (let ((restart (nth-restart index)))
+ (when restart
+ (invoke-restart-interactively restart))))
+
+(defslimefun sldb-abort ()
+ (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
+
+(defslimefun sldb-continue ()
+ (continue))
+
+(defun coerce-to-condition (datum args)
+ (etypecase datum
+ (string (make-condition 'simple-error :format-control datum
+ :format-arguments args))
+ (symbol (apply #'make-condition datum args))))
+
+(defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args)
+ (with-simple-restart (continue "Continue from break.")
+ (invoke-slime-debugger (coerce-to-condition datum args))))
+
+;; FIXME: (last (compute-restarts)) looks dubious.
+(defslimefun throw-to-toplevel ()
+ "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
+If we are not evaluating an RPC then ABORT instead."
+ (let ((restart (or (and *sldb-quit-restart*
+ (find-restart *sldb-quit-restart*))
+ (car (last (compute-restarts))))))
+ (cond (restart (invoke-restart restart))
+ (t (format nil "Restart not active [~s]" *sldb-quit-restart*)))))
+
+(defslimefun invoke-nth-restart-for-emacs (sldb-level n)
+ "Invoke the Nth available restart.
+SLDB-LEVEL is the debug level when the request was made. If this
+has changed, ignore the request."
+ (when (= sldb-level *sldb-level*)
+ (invoke-nth-restart n)))
+
+(defun wrap-sldb-vars (form)
+ `(let ((*sldb-level* ,*sldb-level*))
+ ,form))
+
+(defun eval-in-frame-aux (frame string package print)
+ (let* ((form (wrap-sldb-vars (parse-string string package)))
+ (values (multiple-value-list (eval-in-frame form frame))))
+ (with-buffer-syntax (package)
+ (funcall print values))))
+
+(defslimefun eval-string-in-frame (string frame package)
+ (eval-in-frame-aux frame string package #'format-values-for-echo-area))
+
+(defslimefun pprint-eval-string-in-frame (string frame package)
+ (eval-in-frame-aux frame string package #'swank-pprint))
+
+(defslimefun frame-package-name (frame)
+ (let ((pkg (frame-package frame)))
+ (cond (pkg (package-name pkg))
+ (t (with-buffer-syntax () (package-name *package*))))))
+
+(defslimefun frame-locals-and-catch-tags (index)
+ "Return a list (LOCALS TAGS) for vars and catch tags in the frame INDEX.
+LOCALS is a list of the form ((&key NAME ID VALUE) ...).
+TAGS has is a list of strings."
+ (list (frame-locals-for-emacs index)
+ (mapcar #'to-string (frame-catch-tags index))))
+
+(defun frame-locals-for-emacs (index)
+ (with-bindings *backtrace-printer-bindings*
+ (loop for var in (frame-locals index) collect
+ (destructuring-bind (&key name id value) var
+ (list :name (let ((*package* (or (frame-package index) *package*)))
+ (prin1-to-string name))
+ :id id
+ :value (to-line value *print-right-margin*))))))
+
+(defslimefun sldb-disassemble (index)
+ (with-output-to-string (*standard-output*)
+ (disassemble-frame index)))
+
+(defslimefun sldb-return-from-frame (index string)
+ (let ((form (from-string string)))
+ (to-string (multiple-value-list (return-from-frame index form)))))
+
+(defslimefun sldb-break (name)
+ (with-buffer-syntax ()
+ (sldb-break-at-start (read-from-string name))))
+
+(defmacro define-stepper-function (name backend-function-name)
+ `(defslimefun ,name (frame)
+ (cond ((sldb-stepper-condition-p *swank-debugger-condition*)
+ (setq *sldb-stepping-p* t)
+ (,backend-function-name))
+ ((find-restart 'continue)
+ (activate-stepping frame)
+ (setq *sldb-stepping-p* t)
+ (continue))
+ (t
+ (error "Not currently single-stepping, ~
+and no continue restart available.")))))
+
+(define-stepper-function sldb-step sldb-step-into)
+(define-stepper-function sldb-next sldb-step-next)
+(define-stepper-function sldb-out sldb-step-out)
+
+(defslimefun toggle-break-on-signals ()
+ (setq *break-on-signals* (not *break-on-signals*))
+ (format nil "*break-on-signals* = ~a" *break-on-signals*))
+
+(defslimefun sdlb-print-condition ()
+ (princ-to-string *swank-debugger-condition*))
+
+
+;;;; Compilation Commands.
+
+(defstruct (:compilation-result
+ (:type list) :named)
+ notes
+ (successp nil :type boolean)
+ (duration 0.0 :type float)
+ (loadp nil :type boolean)
+ (faslfile nil :type (or null string)))
+
+(defun measure-time-interval (fun)
+ "Call FUN and return the first return value and the elapsed time.
+The time is measured in seconds."
+ (declare (type function fun))
+ (let ((before (get-internal-real-time)))
+ (values
+ (funcall fun)
+ (/ (- (get-internal-real-time) before)
+ (coerce internal-time-units-per-second 'float)))))
+
+(defun make-compiler-note (condition)
+ "Make a compiler note data structure from a compiler-condition."
+ (declare (type compiler-condition condition))
+ (list* :message (message condition)
+ :severity (severity condition)
+ :location (location condition)
+ :references (references condition)
+ (let ((s (source-context condition)))
+ (if s (list :source-context s)))))
+
+(defun collect-notes (function)
+ (let ((notes '()))
+ (multiple-value-bind (result seconds)
+ (handler-bind ((compiler-condition
+ (lambda (c) (push (make-compiler-note c) notes))))
+ (measure-time-interval
+ (lambda ()
+ ;; To report location of error-signaling toplevel forms
+ ;; for errors in EVAL-WHEN or during macroexpansion.
+ (restart-case (multiple-value-list (funcall function))
+ (abort () :report "Abort compilation." (list nil))))))
+ (destructuring-bind (successp &optional loadp faslfile) result
+ (let ((faslfile (etypecase faslfile
+ (null nil)
+ (pathname (pathname-to-filename faslfile)))))
+ (make-compilation-result :notes (reverse notes)
+ :duration seconds
+ :successp (if successp t)
+ :loadp (if loadp t)
+ :faslfile faslfile))))))
+
+(defun swank-compile-file* (pathname load-p &rest options &key policy
+ &allow-other-keys)
+ (multiple-value-bind (output-pathname warnings? failure?)
+ (swank-compile-file pathname
+ (fasl-pathname pathname options)
+ nil
+ (or (guess-external-format pathname)
+ :default)
+ :policy policy)
+ (declare (ignore warnings?))
+ (values t (not failure?) load-p output-pathname)))
+
+(defvar *compile-file-for-emacs-hook* '(swank-compile-file*))
+
+(defslimefun compile-file-for-emacs (filename load-p &rest options)
+ "Compile FILENAME and, when LOAD-P, load the result.
+Record compiler notes signalled as `compiler-condition's."
+ (with-buffer-syntax ()
+ (collect-notes
+ (lambda ()
+ (let ((pathname (filename-to-pathname filename))
+ (*compile-print* nil)
+ (*compile-verbose* t))
+ (loop for hook in *compile-file-for-emacs-hook*
+ do
+ (multiple-value-bind (tried success load? output-pathname)
+ (apply hook pathname load-p options)
+ (when tried
+ (return (values success load? output-pathname))))))))))
+
+;; FIXME: now that *compile-file-for-emacs-hook* is there this is
+;; redundant and confusing.
+(defvar *fasl-pathname-function* nil
+ "In non-nil, use this function to compute the name for fasl-files.")
+
+(defun pathname-as-directory (pathname)
+ (append (pathname-directory pathname)
+ (when (pathname-name pathname)
+ (list (file-namestring pathname)))))
+
+(defun compile-file-output (file directory)
+ (make-pathname :directory (pathname-as-directory directory)
+ :defaults (compile-file-pathname file)))
+
+(defun fasl-pathname (input-file options)
+ (cond (*fasl-pathname-function*
+ (funcall *fasl-pathname-function* input-file options))
+ ((getf options :fasl-directory)
+ (let ((dir (getf options :fasl-directory)))
+ (assert (char= (aref dir (1- (length dir))) #\/))
+ (compile-file-output input-file dir)))
+ (t
+ (compile-file-pathname input-file))))
+
+(defslimefun compile-string-for-emacs (string buffer position filename policy)
+ "Compile STRING (exerpted from BUFFER at POSITION).
+Record compiler notes signalled as `compiler-condition's."
+ (let ((offset (cadr (assoc :position position))))
+ (with-buffer-syntax ()
+ (collect-notes
+ (lambda ()
+ (let ((*compile-print* t) (*compile-verbose* nil))
+ (swank-compile-string string
+ :buffer buffer
+ :position offset
+ :filename filename
+ :policy policy)))))))
+
+(defslimefun compile-multiple-strings-for-emacs (strings policy)
+ "Compile STRINGS (exerpted from BUFFER at POSITION).
+Record compiler notes signalled as `compiler-condition's."
+ (loop for (string buffer package position filename) in strings collect
+ (collect-notes
+ (lambda ()
+ (with-buffer-syntax (package)
+ (let ((*compile-print* t) (*compile-verbose* nil))
+ (swank-compile-string string
+ :buffer buffer
+ :position position
+ :filename filename
+ :policy policy)))))))
+
+(defun file-newer-p (new-file old-file)
+ "Returns true if NEW-FILE is newer than OLD-FILE."
+ (> (file-write-date new-file) (file-write-date old-file)))
+
+(defun requires-compile-p (source-file)
+ (let ((fasl-file (probe-file (compile-file-pathname source-file))))
+ (or (not fasl-file)
+ (file-newer-p source-file fasl-file))))
+
+(defslimefun compile-file-if-needed (filename loadp)
+ (let ((pathname (filename-to-pathname filename)))
+ (cond ((requires-compile-p pathname)
+ (compile-file-for-emacs pathname loadp))
+ (t
+ (collect-notes
+ (lambda ()
+ (or (not loadp)
+ (load (compile-file-pathname pathname)))))))))
+
+
+;;;; Loading
+
+(defslimefun load-file (filename)
+ (to-string (load (filename-to-pathname filename))))
+
+
+;;;;; swank-require
+
+(defslimefun swank-require (modules &optional filename)
+ "Load the module MODULE."
+ (dolist (module (ensure-list modules))
+ (unless (member (string module) *modules* :test #'string=)
+ (require module (if filename
+ (filename-to-pathname filename)
+ (module-filename module)))
+ (assert (member (string module) *modules* :test #'string=)
+ () "Required module ~s was not provided" module)))
+ *modules*)
+
+(defvar *find-module* 'find-module
+ "Pluggable function to locate modules.
+The function receives a module name as argument and should return
+the filename of the module (or nil if the file doesn't exist).")
+
+(defun module-filename (module)
+ "Return the filename for the module MODULE."
+ (or (funcall *find-module* module)
+ (error "Can't locate module: ~s" module)))
+
+;;;;;; Simple *find-module* function.
+
+(defun merged-directory (dirname defaults)
+ (pathname-directory
+ (merge-pathnames
+ (make-pathname :directory `(:relative ,dirname) :defaults defaults)
+ defaults)))
+
+(defvar *load-path* '()
+ "A list of directories to search for modules.")
+
+(defun module-candidates (name dir)
+ (list (compile-file-pathname (make-pathname :name name :defaults dir))
+ (make-pathname :name name :type "lisp" :defaults dir)))
+
+(defun find-module (module)
+ (let ((name (string-downcase module)))
+ (some (lambda (dir) (some #'probe-file (module-candidates name dir)))
+ *load-path*)))
+
+
+;;;; Macroexpansion
+
+(defvar *macroexpand-printer-bindings*
+ '((*print-circle* . nil)
+ (*print-pretty* . t)
+ (*print-escape* . t)
+ (*print-lines* . nil)
+ (*print-level* . nil)
+ (*print-length* . nil)))
+
+(defun apply-macro-expander (expander string)
+ (with-buffer-syntax ()
+ (with-bindings *macroexpand-printer-bindings*
+ (prin1-to-string (funcall expander (from-string string))))))
+
+(defslimefun swank-macroexpand-1 (string)
+ (apply-macro-expander #'macroexpand-1 string))
+
+(defslimefun swank-macroexpand (string)
+ (apply-macro-expander #'macroexpand string))
+
+(defslimefun swank-macroexpand-all (string)
+ (apply-macro-expander #'macroexpand-all string))
+
+(defslimefun swank-compiler-macroexpand-1 (string)
+ (apply-macro-expander #'compiler-macroexpand-1 string))
+
+(defslimefun swank-compiler-macroexpand (string)
+ (apply-macro-expander #'compiler-macroexpand string))
+
+(defslimefun swank-expand-1 (string)
+ (apply-macro-expander #'expand-1 string))
+
+(defslimefun swank-expand (string)
+ (apply-macro-expander #'expand string))
+
+(defun expand-1 (form)
+ (multiple-value-bind (expansion expanded?) (macroexpand-1 form)
+ (if expanded?
+ (values expansion t)
+ (compiler-macroexpand-1 form))))
+
+(defun expand (form)
+ (expand-repeatedly #'expand-1 form))
+
+(defun expand-repeatedly (expander form)
+ (loop
+ (multiple-value-bind (expansion expanded?) (funcall expander form)
+ (unless expanded? (return expansion))
+ (setq form expansion))))
+
+(defslimefun swank-format-string-expand (string)
+ (apply-macro-expander #'format-string-expand string))
+
+(defslimefun disassemble-form (form)
+ (with-buffer-syntax ()
+ (with-output-to-string (*standard-output*)
+ (let ((*print-readably* nil))
+ (disassemble (eval (read-from-string form)))))))
+
+
+;;;; Simple completion
+
+(defslimefun simple-completions (prefix package)
+ "Return a list of completions for the string PREFIX."
+ (let ((strings (all-completions prefix package)))
+ (list strings (longest-common-prefix strings))))
+
+(defun all-completions (prefix package)
+ (multiple-value-bind (name pname intern) (tokenize-symbol prefix)
+ (let* ((extern (and pname (not intern)))
+ (pkg (cond ((equal pname "") keyword-package)
+ ((not pname) (guess-buffer-package package))
+ (t (guess-package pname))))
+ (test (lambda (sym) (prefix-match-p name (symbol-name sym))))
+ (syms (and pkg (matching-symbols pkg extern test)))
+ (strings (loop for sym in syms
+ for str = (unparse-symbol sym)
+ when (prefix-match-p name str) ; remove |Foo|
+ collect str)))
+ (format-completion-set strings intern pname))))
+
+(defun matching-symbols (package external test)
+ (let ((test (if external
+ (lambda (s)
+ (and (symbol-external-p s package)
+ (funcall test s)))
+ test))
+ (result '()))
+ (do-symbols (s package)
+ (when (funcall test s)
+ (push s result)))
+ (remove-duplicates result)))
+
+(defun unparse-symbol (symbol)
+ (let ((*print-case* (case (readtable-case *readtable*)
+ (:downcase :upcase)
+ (t :downcase))))
+ (unparse-name (symbol-name symbol))))
+
+(defun prefix-match-p (prefix string)
+ "Return true if PREFIX is a prefix of STRING."
+ (not (mismatch prefix string :end2 (min (length string) (length prefix))
+ :test #'char-equal)))
+
+(defun longest-common-prefix (strings)
+ "Return the longest string that is a common prefix of STRINGS."
+ (if (null strings)
+ ""
+ (flet ((common-prefix (s1 s2)
+ (let ((diff-pos (mismatch s1 s2)))
+ (if diff-pos (subseq s1 0 diff-pos) s1))))
+ (reduce #'common-prefix strings))))
+
+(defun format-completion-set (strings internal-p package-name)
+ "Format a set of completion strings.
+Returns a list of completions with package qualifiers if needed."
+ (mapcar (lambda (string) (untokenize-symbol package-name internal-p string))
+ (sort strings #'string<)))
+
+
+;;;; Simple arglist display
+
+(defslimefun operator-arglist (name package)
+ (ignore-errors
+ (let ((args (arglist (parse-symbol name (guess-buffer-package package)))))
+ (cond ((eq args :not-available) nil)
+ (t (princ-to-string (cons name args)))))))
+
+
+;;;; Documentation
+
+(defslimefun apropos-list-for-emacs (name &optional external-only
+ case-sensitive package)
+ "Make an apropos search for Emacs.
+The result is a list of property lists."
+ (let ((package (if package
+ (or (parse-package package)
+ (error "No such package: ~S" package)))))
+ ;; The MAPCAN will filter all uninteresting symbols, i.e. those
+ ;; who cannot be meaningfully described.
+ (mapcan (listify #'briefly-describe-symbol-for-emacs)
+ (sort (remove-duplicates
+ (apropos-symbols name external-only case-sensitive package))
+ #'present-symbol-before-p))))
+
+(defun briefly-describe-symbol-for-emacs (symbol)
+ "Return a property list describing SYMBOL.
+Like `describe-symbol-for-emacs' but with at most one line per item."
+ (flet ((first-line (string)
+ (let ((pos (position #\newline string)))
+ (if (null pos) string (subseq string 0 pos)))))
+ (let ((desc (map-if #'stringp #'first-line
+ (describe-symbol-for-emacs symbol))))
+ (if desc
+ (list* :designator (to-string symbol) desc)))))
+
+(defun map-if (test fn &rest lists)
+ "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
+Example:
+\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
+ (apply #'mapcar
+ (lambda (x) (if (funcall test x) (funcall fn x) x))
+ lists))
+
+(defun listify (f)
+ "Return a function like F, but which returns any non-null value
+wrapped in a list."
+ (lambda (x)
+ (let ((y (funcall f x)))
+ (and y (list y)))))
+
+(defun present-symbol-before-p (x y)
+ "Return true if X belongs before Y in a printed summary of symbols.
+Sorted alphabetically by package name and then symbol name, except
+that symbols accessible in the current package go first."
+ (declare (type symbol x y))
+ (flet ((accessible (s)
+ ;; Test breaks on NIL for package that does not inherit it
+ (eq (find-symbol (symbol-name s) *buffer-package*) s)))
+ (let ((ax (accessible x)) (ay (accessible y)))
+ (cond ((and ax ay) (string< (symbol-name x) (symbol-name y)))
+ (ax t)
+ (ay nil)
+ (t (let ((px (symbol-package x)) (py (symbol-package y)))
+ (if (eq px py)
+ (string< (symbol-name x) (symbol-name y))
+ (string< (package-name px) (package-name py)))))))))
+
+(defun make-apropos-matcher (pattern case-sensitive)
+ (let ((chr= (if case-sensitive #'char= #'char-equal)))
+ (lambda (symbol)
+ (search pattern (string symbol) :test chr=))))
+
+(defun apropos-symbols (string external-only case-sensitive package)
+ (let ((packages (or package (remove (find-package :keyword)
+ (list-all-packages))))
+ (matcher (make-apropos-matcher string case-sensitive))
+ (result))
+ (with-package-iterator (next packages :external :internal)
+ (loop (multiple-value-bind (morep symbol) (next)
+ (cond ((not morep) (return))
+ ((and (if external-only (symbol-external-p symbol) t)
+ (funcall matcher symbol))
+ (push symbol result))))))
+ result))
+
+(defun call-with-describe-settings (fn)
+ (let ((*print-readably* nil))
+ (funcall fn)))
+
+(defmacro with-describe-settings ((&rest _) &body body)
+ (declare (ignore _))
+ `(call-with-describe-settings (lambda () ,@body)))
+
+(defun describe-to-string (object)
+ (with-describe-settings ()
+ (with-output-to-string (*standard-output*)
+ (describe object))))
+
+(defslimefun describe-symbol (symbol-name)
+ (with-buffer-syntax ()
+ (describe-to-string (parse-symbol-or-lose symbol-name))))
+
+(defslimefun describe-function (name)
+ (with-buffer-syntax ()
+ (let ((symbol (parse-symbol-or-lose name)))
+ (describe-to-string (or (macro-function symbol)
+ (symbol-function symbol))))))
+
+(defslimefun describe-definition-for-emacs (name kind)
+ (with-buffer-syntax ()
+ (with-describe-settings ()
+ (with-output-to-string (*standard-output*)
+ (describe-definition (parse-symbol-or-lose name) kind)))))
+
+(defslimefun documentation-symbol (symbol-name)
+ (with-buffer-syntax ()
+ (multiple-value-bind (sym foundp) (parse-symbol symbol-name)
+ (if foundp
+ (let ((vdoc (documentation sym 'variable))
+ (fdoc (documentation sym 'function)))
+ (with-output-to-string (string)
+ (format string "Documentation for the symbol ~a:~2%" sym)
+ (unless (or vdoc fdoc)
+ (format string "Not documented." ))
+ (when vdoc
+ (format string "Variable:~% ~a~2%" vdoc))
+ (when fdoc
+ (format string "Function:~% Arglist: ~a~2% ~a"
+ (arglist sym)
+ fdoc))))
+ (format nil "No such symbol, ~a." symbol-name)))))
+
+
+;;;; Package Commands
+
+(defslimefun list-all-package-names (&optional nicknames)
+ "Return a list of all package names.
+Include the nicknames if NICKNAMES is true."
+ (mapcar #'unparse-name
+ (if nicknames
+ (mapcan #'package-names (list-all-packages))
+ (mapcar #'package-name (list-all-packages)))))
+
+
+;;;; Tracing
+
+;; Use eval for the sake of portability...
+(defun tracedp (fspec)
+ (member fspec (eval '(trace))))
+
+(defvar *after-toggle-trace-hook* nil
+ "Hook called whenever a SPEC is traced or untraced.
+
+If non-nil, called with two arguments SPEC and TRACED-P." )
+(defslimefun swank-toggle-trace (spec-string)
+ (let* ((spec (from-string spec-string))
+ (retval (cond ((consp spec) ; handle complicated cases in the backend
+ (toggle-trace spec))
+ ((tracedp spec)
+ (eval `(untrace ,spec))
+ (format nil "~S is now untraced." spec))
+ (t
+ (eval `(trace ,spec))
+ (format nil "~S is now traced." spec))))
+ (traced-p (let* ((tosearch "is now traced.")
+ (start (- (length retval)
+ (length tosearch)))
+ (end (+ start (length tosearch))))
+ (search tosearch (subseq retval start end))))
+ (hook-msg (when *after-toggle-trace-hook*
+ (funcall *after-toggle-trace-hook*
+ spec
+ traced-p))))
+ (if hook-msg
+ (format nil "~a~%(also ~a)" retval hook-msg)
+ retval)))
+
+(defslimefun untrace-all ()
+ (untrace))
+
+
+;;;; Undefing
+
+(defslimefun undefine-function (fname-string)
+ (let ((fname (from-string fname-string)))
+ (format nil "~S" (fmakunbound fname))))
+
+(defslimefun unintern-symbol (name package)
+ (let ((pkg (guess-package package)))
+ (cond ((not pkg) (format nil "No such package: ~s" package))
+ (t
+ (multiple-value-bind (sym found) (parse-symbol name pkg)
+ (case found
+ ((nil) (format nil "~s not in package ~s" name package))
+ (t
+ (unintern sym pkg)
+ (format nil "Uninterned symbol: ~s" sym))))))))
+
+(defslimefun swank-delete-package (package-name)
+ (let ((pkg (or (guess-package package-name)
+ (error "No such package: ~s" package-name))))
+ (delete-package pkg)
+ nil))
+
+
+;;;; Profiling
+
+(defun profiledp (fspec)
+ (member fspec (profiled-functions)))
+
+(defslimefun toggle-profile-fdefinition (fname-string)
+ (let ((fname (from-string fname-string)))
+ (cond ((profiledp fname)
+ (unprofile fname)
+ (format nil "~S is now unprofiled." fname))
+ (t
+ (profile fname)
+ (format nil "~S is now profiled." fname)))))
+
+(defslimefun profile-by-substring (substring package)
+ (let ((count 0))
+ (flet ((maybe-profile (symbol)
+ (when (and (fboundp symbol)
+ (not (profiledp symbol))
+ (search substring (symbol-name symbol) :test #'equalp))
+ (handler-case (progn
+ (profile symbol)
+ (incf count))
+ (error (condition)
+ (warn "~a" condition))))))
+ (if package
+ (do-symbols (symbol (parse-package package))
+ (maybe-profile symbol))
+ (do-all-symbols (symbol)
+ (maybe-profile symbol))))
+ (format nil "~a function~:p ~:*~[are~;is~:;are~] now profiled" count)))
+
+(defslimefun swank-profile-package (package-name callersp methodsp)
+ (let ((pkg (or (guess-package package-name)
+ (error "Not a valid package name: ~s" package-name))))
+ (check-type callersp boolean)
+ (check-type methodsp boolean)
+ (profile-package pkg callersp methodsp)))
+
+
+;;;; Source Locations
+
+(defslimefun find-definition-for-thing (thing)
+ (find-source-location thing))
+
+(defslimefun find-source-location-for-emacs (spec)
+ (find-source-location (value-spec-ref spec)))
+
+(defun value-spec-ref (spec)
+ (dcase spec
+ ((:string string package)
+ (with-buffer-syntax (package)
+ (eval (read-from-string string))))
+ ((:inspector part)
+ (inspector-nth-part part))
+ ((:sldb frame var)
+ (frame-var-value frame var))))
+
+(defvar *find-definitions-right-trim* ",:.>")
+(defvar *find-definitions-left-trim* "#:<")
+
+(defun find-definitions-find-symbol-or-package (name)
+ (flet ((do-find (name)
+ (multiple-value-bind (symbol found name)
+ (with-buffer-syntax ()
+ (parse-symbol name))
+ (cond (found
+ (return-from find-definitions-find-symbol-or-package
+ (values symbol found)))
+ ;; Packages are not named by symbols, so
+ ;; not-interned symbols can refer to packages
+ ((find-package name)
+ (return-from find-definitions-find-symbol-or-package
+ (values (make-symbol name) t)))))))
+ (do-find name)
+ (do-find (string-right-trim *find-definitions-right-trim* name))
+ (do-find (string-left-trim *find-definitions-left-trim* name))
+ (do-find (string-left-trim *find-definitions-left-trim*
+ (string-right-trim
+ *find-definitions-right-trim* name)))))
+
+(defslimefun find-definitions-for-emacs (name)
+ "Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
+DSPEC is a string and LOCATION a source location. NAME is a string."
+ (multiple-value-bind (symbol found)
+ (find-definitions-find-symbol-or-package name)
+ (when found
+ (mapcar #'xref>elisp (find-definitions symbol)))))
+
+;;; Generic function so contribs can extend it.
+(defgeneric xref-doit (type thing)
+ (:method (type thing)
+ (declare (ignore type thing))
+ :not-implemented))
+
+(macrolet ((define-xref-action (xref-type handler)
+ `(defmethod xref-doit ((type (eql ,xref-type)) thing)
+ (declare (ignorable type))
+ (funcall ,handler thing))))
+ (define-xref-action :calls #'who-calls)
+ (define-xref-action :calls-who #'calls-who)
+ (define-xref-action :references #'who-references)
+ (define-xref-action :binds #'who-binds)
+ (define-xref-action :sets #'who-sets)
+ (define-xref-action :macroexpands #'who-macroexpands)
+ (define-xref-action :specializes #'who-specializes)
+ (define-xref-action :callers #'list-callers)
+ (define-xref-action :callees #'list-callees))
+
+(defslimefun xref (type name)
+ (multiple-value-bind (sexp error) (ignore-errors (from-string name))
+ (unless error
+ (let ((xrefs (xref-doit type sexp)))
+ (if (eq xrefs :not-implemented)
+ :not-implemented
+ (mapcar #'xref>elisp xrefs))))))
+
+(defslimefun xrefs (types name)
+ (loop for type in types
+ for xrefs = (xref type name)
+ when (and (not (eq :not-implemented xrefs))
+ (not (null xrefs)))
+ collect (cons type xrefs)))
+
+(defun xref>elisp (xref)
+ (destructuring-bind (name loc) xref
+ (list (to-string name) loc)))
+
+
+;;;;; Lazy lists
+
+(defstruct (lcons (:constructor %lcons (car %cdr))
+ (:predicate lcons?))
+ car
+ (%cdr nil :type (or null lcons function))
+ (forced? nil))
+
+(defmacro lcons (car cdr)
+ `(%lcons ,car (lambda () ,cdr)))
+
+(defmacro lcons* (car cdr &rest more)
+ (cond ((null more) `(lcons ,car ,cdr))
+ (t `(lcons ,car (lcons* ,cdr ,@more)))))
+
+(defun lcons-cdr (lcons)
+ (with-struct* (lcons- @ lcons)
+ (cond ((@ forced?)
+ (@ %cdr))
+ (t
+ (let ((value (funcall (@ %cdr))))
+ (setf (@ forced?) t
+ (@ %cdr) value))))))
+
+(defun llist-range (llist start end)
+ (llist-take (llist-skip llist start) (- end start)))
+
+(defun llist-skip (lcons index)
+ (do ((i 0 (1+ i))
+ (l lcons (lcons-cdr l)))
+ ((or (= i index) (null l))
+ l)))
+
+(defun llist-take (lcons count)
+ (let ((result '()))
+ (do ((i 0 (1+ i))
+ (l lcons (lcons-cdr l)))
+ ((or (= i count)
+ (null l)))
+ (push (lcons-car l) result))
+ (nreverse result)))
+
+(defun iline (label value)
+ `(:line ,label ,value))
+
+
+;;;; Inspecting
+
+(defvar *inspector-verbose* nil)
+
+(defvar *inspector-printer-bindings*
+ '((*print-lines* . 1)
+ (*print-right-margin* . 75)
+ (*print-pretty* . t)
+ (*print-readably* . nil)))
+
+(defvar *inspector-verbose-printer-bindings*
+ '((*print-escape* . t)
+ (*print-circle* . t)
+ (*print-array* . nil)))
+
+(defstruct inspector-state)
+(defstruct (istate (:conc-name istate.) (:include inspector-state))
+ object
+ (verbose *inspector-verbose*)
+ (parts (make-array 10 :adjustable t :fill-pointer 0))
+ (actions (make-array 10 :adjustable t :fill-pointer 0))
+ metadata-plist
+ content
+ next previous)
+
+(defvar *istate* nil)
+(defvar *inspector-history*)
+
+(defun reset-inspector ()
+ (setq *istate* nil
+ *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
+
+(defslimefun init-inspector (string)
+ (with-buffer-syntax ()
+ (with-retry-restart (:msg "Retry SLIME inspection request.")
+ (reset-inspector)
+ (inspect-object (eval (read-from-string string))))))
+
+(defun ensure-istate-metadata (o indicator default)
+ (with-struct (istate. object metadata-plist) *istate*
+ (assert (eq object o))
+ (let ((data (getf metadata-plist indicator default)))
+ (setf (getf metadata-plist indicator) data)
+ data)))
+
+(defun inspect-object (o)
+ (let* ((prev *istate*)
+ (istate (make-istate :object o :previous prev
+ :verbose (cond (prev (istate.verbose prev))
+ (t *inspector-verbose*)))))
+ (setq *istate* istate)
+ (setf (istate.content istate) (emacs-inspect/istate istate))
+ (unless (find o *inspector-history*)
+ (vector-push-extend o *inspector-history*))
+ (let ((previous (istate.previous istate)))
+ (if previous (setf (istate.next previous) istate)))
+ (istate>elisp istate)))
+
+(defun emacs-inspect/istate (istate)
+ (with-bindings (if (istate.verbose istate)
+ *inspector-verbose-printer-bindings*
+ *inspector-printer-bindings*)
+ (emacs-inspect (istate.object istate))))
+
+(defun istate>elisp (istate)
+ (list :title (prepare-title istate)
+ :id (assign-index (istate.object istate) (istate.parts istate))
+ :content (prepare-range istate 0 500)))
+
+(defun prepare-title (istate)
+ (if (istate.verbose istate)
+ (with-bindings *inspector-verbose-printer-bindings*
+ (to-string (istate.object istate)))
+ (with-string-stream (stream :length 200
+ :bindings *inspector-printer-bindings*)
+ (print-unreadable-object
+ ((istate.object istate) stream :type t :identity t)))))
+
+(defun prepare-range (istate start end)
+ (let* ((range (content-range (istate.content istate) start end))
+ (ps (loop for part in range append (prepare-part part istate))))
+ (list ps
+ (if (< (length ps) (- end start))
+ (+ start (length ps))
+ (+ end 1000))
+ start end)))
+
+(defun prepare-part (part istate)
+ (let ((newline '#.(string #\newline)))
+ (etypecase part
+ (string (list part))
+ (cons (dcase part
+ ((:newline) (list newline))
+ ((:value obj &optional str)
+ (list (value-part obj str (istate.parts istate))))
+ ((:label &rest strs)
+ (list (list :label (apply #'cat (mapcar #'string strs)))))
+ ((:action label lambda &key (refreshp t))
+ (list (action-part label lambda refreshp
+ (istate.actions istate))))
+ ((:line label value)
+ (list (princ-to-string label) ": "
+ (value-part value nil (istate.parts istate))
+ newline)))))))
+
+(defun value-part (object string parts)
+ (list :value
+ (or string (print-part-to-string object))
+ (assign-index object parts)))
+
+(defun action-part (label lambda refreshp actions)
+ (list :action label (assign-index (list lambda refreshp) actions)))
+
+(defun assign-index (object vector)
+ (let ((index (fill-pointer vector)))
+ (vector-push-extend object vector)
+ index))
+
+(defun print-part-to-string (value)
+ (let* ((*print-readably* nil)
+ (string (to-line value))
+ (pos (position value *inspector-history*)))
+ (if pos
+ (format nil "@~D=~A" pos string)
+ string)))
+
+(defun content-range (list start end)
+ (typecase list
+ (list (let ((len (length list)))
+ (subseq list start (min len end))))
+ (lcons (llist-range list start end))))
+
+(defslimefun inspector-nth-part (index)
+ "Return the current inspector's INDEXth part.
+The second value indicates if that part exists at all."
+ (let* ((parts (istate.parts *istate*))
+ (foundp (< index (length parts))))
+ (values (and foundp (aref parts index))
+ foundp)))
+
+(defslimefun inspect-nth-part (index)
+ (with-buffer-syntax ()
+ (inspect-object (inspector-nth-part index))))
+
+(defslimefun inspector-range (from to)
+ (prepare-range *istate* from to))
+
+(defslimefun inspector-call-nth-action (index &rest args)
+ (destructuring-bind (fun refreshp) (aref (istate.actions *istate*) index)
+ (apply fun args)
+ (if refreshp
+ (inspector-reinspect)
+ ;; tell emacs that we don't want to refresh the inspector buffer
+ nil)))
+
+(defslimefun inspector-pop ()
+ "Inspect the previous object.
+Return nil if there's no previous object."
+ (with-buffer-syntax ()
+ (cond ((istate.previous *istate*)
+ (setq *istate* (istate.previous *istate*))
+ (istate>elisp *istate*))
+ (t nil))))
+
+(defslimefun inspector-next ()
+ "Inspect the next element in the history of inspected objects.."
+ (with-buffer-syntax ()
+ (cond ((istate.next *istate*)
+ (setq *istate* (istate.next *istate*))
+ (istate>elisp *istate*))
+ (t nil))))
+
+(defslimefun inspector-reinspect ()
+ (let ((istate *istate*))
+ (setf (istate.content istate) (emacs-inspect/istate istate))
+ (istate>elisp istate)))
+
+(defslimefun inspector-toggle-verbose ()
+ "Toggle verbosity of inspected object."
+ (setf (istate.verbose *istate*) (not (istate.verbose *istate*)))
+ (istate>elisp *istate*))
+
+(defslimefun inspector-eval (string)
+ (let* ((obj (istate.object *istate*))
+ (context (eval-context obj))
+ (form (with-buffer-syntax ((cdr (assoc '*package* context)))
+ (read-from-string string)))
+ (ignorable (remove-if #'boundp (mapcar #'car context))))
+ (to-string (eval `(let ((* ',obj) (- ',form)
+ . ,(loop for (var . val) in context
+ unless (constantp var) collect
+ `(,var ',val)))
+ (declare (ignorable . ,ignorable))
+ ,form)))))
+
+(defslimefun inspector-history ()
+ (with-output-to-string (out)
+ (let ((newest (loop for s = *istate* then next
+ for next = (istate.next s)
+ if (not next) return s)))
+ (format out "--- next/prev chain ---")
+ (loop for s = newest then (istate.previous s) while s do
+ (let ((val (istate.object s)))
+ (format out "~%~:[ ~; *~]@~d "
+ (eq s *istate*)
+ (position val *inspector-history*))
+ (print-unreadable-object (val out :type t :identity t)))))
+ (format out "~%~%--- all visited objects ---")
+ (loop for val across *inspector-history* for i from 0 do
+ (format out "~%~2,' d " i)
+ (print-unreadable-object (val out :type t :identity t)))))
+
+(defslimefun quit-inspector ()
+ (reset-inspector)
+ nil)
+
+(defslimefun describe-inspectee ()
+ "Describe the currently inspected object."
+ (with-buffer-syntax ()
+ (describe-to-string (istate.object *istate*))))
+
+(defslimefun pprint-inspector-part (index)
+ "Pretty-print the currently inspected object."
+ (with-buffer-syntax ()
+ (swank-pprint (list (inspector-nth-part index)))))
+
+(defslimefun inspect-in-frame (string index)
+ (with-buffer-syntax ()
+ (with-retry-restart (:msg "Retry SLIME inspection request.")
+ (reset-inspector)
+ (inspect-object (eval-in-frame (from-string string) index)))))
+
+(defslimefun inspect-current-condition ()
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (inspect-object *swank-debugger-condition*)))
+
+(defslimefun inspect-frame-var (frame var)
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (inspect-object (frame-var-value frame var))))
+
+;;;;; Lists
+
+(defmethod emacs-inspect ((o cons))
+ (if (listp (cdr o))
+ (inspect-list o)
+ (inspect-cons o)))
+
+(defun inspect-cons (cons)
+ (label-value-line*
+ ('car (car cons))
+ ('cdr (cdr cons))))
+
+(defun inspect-list (list)
+ (multiple-value-bind (length tail) (safe-length list)
+ (flet ((frob (title list)
+ (list* title '(:newline) (inspect-list-aux list))))
+ (cond ((not length)
+ (frob "A circular list:"
+ (cons (car list)
+ (ldiff (cdr list) list))))
+ ((not tail)
+ (frob "A proper list:" list))
+ (t
+ (frob "An improper list:" list))))))
+
+(defun inspect-list-aux (list)
+ (loop for i from 0 for rest on list while (consp rest) append
+ (if (listp (cdr rest))
+ (label-value-line i (car rest))
+ (label-value-line* (i (car rest)) (:tail (cdr rest))))))
+
+(defun safe-length (list)
+ "Similar to `list-length', but avoid errors on improper lists.
+Return two values: the length of the list and the last cdr.
+Return NIL if LIST is circular."
+ (do ((n 0 (+ n 2)) ;Counter.
+ (fast list (cddr fast)) ;Fast pointer: leaps by 2.
+ (slow list (cdr slow))) ;Slow pointer: leaps by 1.
+ (nil)
+ (cond ((null fast) (return (values n nil)))
+ ((not (consp fast)) (return (values n fast)))
+ ((null (cdr fast)) (return (values (1+ n) (cdr fast))))
+ ((and (eq fast slow) (> n 0)) (return nil))
+ ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
+
+;;;;; Hashtables
+
+(defun hash-table-to-alist (ht)
+ (let ((result '()))
+ (maphash (lambda (key value)
+ (setq result (acons key value result)))
+ ht)
+ result))
+
+(defmethod emacs-inspect ((ht hash-table))
+ (append
+ (label-value-line*
+ ("Count" (hash-table-count ht))
+ ("Size" (hash-table-size ht))
+ ("Test" (hash-table-test ht))
+ ("Rehash size" (hash-table-rehash-size ht))
+ ("Rehash threshold" (hash-table-rehash-threshold ht)))
+ (let ((weakness (hash-table-weakness ht)))
+ (when weakness
+ (label-value-line "Weakness:" weakness)))
+ (unless (zerop (hash-table-count ht))
+ `((:action "[clear hashtable]"
+ ,(lambda () (clrhash ht))) (:newline)
+ "Contents: " (:newline)))
+ (let ((content (hash-table-to-alist ht)))
+ (cond ((every (lambda (x) (typep (first x) '(or string symbol))) content)
+ (setf content (sort content 'string< :key #'first)))
+ ((every (lambda (x) (typep (first x) 'number)) content)
+ (setf content (sort content '< :key #'first))))
+ (loop for (key . value) in content appending
+ `((:value ,key) " = " (:value ,value)
+ " " (:action "[remove entry]"
+ ,(let ((key key))
+ (lambda () (remhash key ht))))
+ (:newline))))))
+
+;;;;; Arrays
+
+(defmethod emacs-inspect ((array array))
+ (lcons*
+ (iline "Dimensions" (array-dimensions array))
+ (iline "Element type" (array-element-type array))
+ (iline "Total size" (array-total-size array))
+ (iline "Adjustable" (adjustable-array-p array))
+ (iline "Fill pointer" (if (array-has-fill-pointer-p array)
+ (fill-pointer array)))
+ "Contents:" '(:newline)
+ (labels ((k (i max)
+ (cond ((= i max) '())
+ (t (lcons (iline i (row-major-aref array i))
+ (k (1+ i) max))))))
+ (k 0 (array-total-size array)))))
+
+;;;;; Chars
+
+(defmethod emacs-inspect ((char character))
+ (append
+ (label-value-line*
+ ("Char code" (char-code char))
+ ("Lower cased" (char-downcase char))
+ ("Upper cased" (char-upcase char)))
+ (if (get-macro-character char)
+ `("In the current readtable ("
+ (:value ,*readtable*) ") it is a macro character: "
+ (:value ,(get-macro-character char))))))
+
+;;;; Thread listing
+
+(defvar *thread-list* ()
+ "List of threads displayed in Emacs. We don't care a about
+synchronization issues (yet). There can only be one thread listing at
+a time.")
+
+(defslimefun list-threads ()
+ "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...).
+LABELS is a list of attribute names and the remaining lists are the
+corresponding attribute values per thread.
+Example:
+ ((:id :name :status :priority)
+ (6 \"swank-indentation-cache-thread\" \"Semaphore timed wait\" 0)
+ (5 \"reader-thread\" \"Active\" 0)
+ (4 \"control-thread\" \"Semaphore timed wait\" 0)
+ (2 \"Swank Sentinel\" \"Semaphore timed wait\" 0)
+ (1 \"listener\" \"Active\" 0)
+ (0 \"Initial\" \"Sleep\" 0))"
+ (setq *thread-list* (all-threads))
+ (when (and *emacs-connection*
+ (use-threads-p)
+ (equalp (thread-name (current-thread)) "worker"))
+ (setf *thread-list* (delete (current-thread) *thread-list*)))
+ (let* ((plist (thread-attributes (car *thread-list*)))
+ (labels (loop for (key) on plist by #'cddr
+ collect key)))
+ `((:id :name :status ,@labels)
+ ,@(loop for thread in *thread-list*
+ for name = (thread-name thread)
+ for attributes = (thread-attributes thread)
+ collect (list* (thread-id thread)
+ (string name)
+ (thread-status thread)
+ (loop for label in labels
+ collect (getf attributes label)))))))
+
+(defslimefun quit-thread-browser ()
+ (setq *thread-list* nil))
+
+(defun nth-thread (index)
+ (nth index *thread-list*))
+
+(defslimefun debug-nth-thread (index)
+ (let ((connection *emacs-connection*))
+ (interrupt-thread (nth-thread index)
+ (lambda ()
+ (invoke-or-queue-interrupt
+ (lambda ()
+ (with-connection (connection)
+ (simple-break))))))))
+
+(defslimefun kill-nth-thread (index)
+ (kill-thread (nth-thread index)))
+
+(defslimefun start-swank-server-in-thread (index port-file-name)
+ "Interrupt the INDEXth thread and make it start a swank server.
+The server port is written to PORT-FILE-NAME."
+ (interrupt-thread (nth-thread index)
+ (lambda ()
+ (start-server port-file-name :style nil))))
+
+;;;; Class browser
+
+(defun mop-helper (class-name fn)
+ (let ((class (find-class class-name nil)))
+ (if class
+ (mapcar (lambda (x) (to-string (class-name x)))
+ (funcall fn class)))))
+
+(defslimefun mop (type symbol-name)
+ "Return info about classes using mop.
+
+ When type is:
+ :subclasses - return the list of subclasses of class.
+ :superclasses - return the list of superclasses of class."
+ (let ((symbol (parse-symbol symbol-name *buffer-package*)))
+ (ecase type
+ (:subclasses
+ (mop-helper symbol #'swank-mop:class-direct-subclasses))
+ (:superclasses
+ (mop-helper symbol #'swank-mop:class-direct-superclasses)))))
+
+
+;;;; Automatically synchronized state
+;;;
+;;; Here we add hooks to push updates of relevant information to
+;;; Emacs.
+
+;;;;; *FEATURES*
+
+(defun sync-features-to-emacs ()
+ "Update Emacs if any relevant Lisp state has changed."
+ ;; FIXME: *slime-features* should be connection-local
+ (unless (eq *slime-features* *features*)
+ (setq *slime-features* *features*)
+ (send-to-emacs (list :new-features (features-for-emacs)))))
+
+(defun features-for-emacs ()
+ "Return `*slime-features*' in a format suitable to send it to Emacs."
+ *slime-features*)
+
+(add-hook *pre-reply-hook* 'sync-features-to-emacs)
+
+
+;;;;; Indentation of macros
+;;;
+;;; This code decides how macros should be indented (based on their
+;;; arglists) and tells Emacs. A per-connection cache is used to avoid
+;;; sending redundant information to Emacs -- we just say what's
+;;; changed since last time.
+;;;
+;;; The strategy is to scan all symbols, pick out the macros, and look
+;;; for &body-arguments.
+
+(defvar *configure-emacs-indentation* t
+ "When true, automatically send indentation information to Emacs
+after each command.")
+
+(defslimefun update-indentation-information ()
+ (send-to-indentation-cache `(:update-indentation-information))
+ nil)
+
+;; This function is for *PRE-REPLY-HOOK*.
+(defun sync-indentation-to-emacs ()
+ "Send any indentation updates to Emacs via CONNECTION."
+ (when *configure-emacs-indentation*
+ (send-to-indentation-cache `(:sync-indentation ,*buffer-package*))))
+
+;; Send REQUEST to the cache. If we are single threaded perform the
+;; request right away, otherwise delegate the request to the
+;; indentation-cache-thread.
+(defun send-to-indentation-cache (request)
+ (let ((c *emacs-connection*))
+ (etypecase c
+ (singlethreaded-connection
+ (handle-indentation-cache-request c request))
+ (multithreaded-connection
+ (without-slime-interrupts
+ (send (mconn.indentation-cache-thread c) request))))))
+
+(defun indentation-cache-loop (connection)
+ (with-connection (connection)
+ (loop
+ (restart-case
+ (handle-indentation-cache-request connection (receive))
+ (abort ()
+ :report "Return to the indentation cache request handling loop.")))))
+
+(defun handle-indentation-cache-request (connection request)
+ (dcase request
+ ((:sync-indentation package)
+ (let ((fullp (need-full-indentation-update-p connection)))
+ (perform-indentation-update connection fullp package)))
+ ((:update-indentation-information)
+ (perform-indentation-update connection t nil))))
+
+(defun need-full-indentation-update-p (connection)
+ "Return true if the whole indentation cache should be updated.
+This is a heuristic to avoid scanning all symbols all the time:
+instead, we only do a full scan if the set of packages has changed."
+ (set-difference (list-all-packages)
+ (connection.indentation-cache-packages connection)))
+
+(defun perform-indentation-update (connection force package)
+ "Update the indentation cache in CONNECTION and update Emacs.
+If FORCE is true then start again without considering the old cache."
+ (let ((cache (connection.indentation-cache connection)))
+ (when force (clrhash cache))
+ (let ((delta (update-indentation/delta-for-emacs cache force package)))
+ (setf (connection.indentation-cache-packages connection)
+ (list-all-packages))
+ (unless (null delta)
+ (setf (connection.indentation-cache connection) cache)
+ (send-to-emacs (list :indentation-update delta))))))
+
+(defun update-indentation/delta-for-emacs (cache force package)
+ "Update the cache and return the changes in a (SYMBOL INDENT PACKAGES) list.
+If FORCE is true then check all symbols, otherwise only check symbols
+belonging to PACKAGE."
+ (let ((alist '()))
+ (flet ((consider (symbol)
+ (let ((indent (symbol-indentation symbol)))
+ (when indent
+ (unless (equal (gethash symbol cache) indent)
+ (setf (gethash symbol cache) indent)
+ (let ((pkgs (mapcar #'package-name
+ (symbol-packages symbol)))
+ (name (string-downcase symbol)))
+ (push (list name indent pkgs) alist)))))))
+ (cond (force
+ (do-all-symbols (symbol)
+ (consider symbol)))
+ ((package-name package) ; don't try to iterate over a
+ ; deleted package.
+ (do-symbols (symbol package)
+ (when (eq (symbol-package symbol) package)
+ (consider symbol)))))
+ alist)))
+
+(defun package-names (package)
+ "Return the name and all nicknames of PACKAGE in a fresh list."
+ (cons (package-name package) (copy-list (package-nicknames package))))
+
+(defun symbol-packages (symbol)
+ "Return the packages where SYMBOL can be found."
+ (let ((string (string symbol)))
+ (loop for p in (list-all-packages)
+ when (eq symbol (find-symbol string p))
+ collect p)))
+
+(defun cl-symbol-p (symbol)
+ "Is SYMBOL a symbol in the COMMON-LISP package?"
+ (eq (symbol-package symbol) cl-package))
+
+(defun known-to-emacs-p (symbol)
+ "Return true if Emacs has special rules for indenting SYMBOL."
+ (cl-symbol-p symbol))
+
+(defun symbol-indentation (symbol)
+ "Return a form describing the indentation of SYMBOL.
+The form is to be used as the `common-lisp-indent-function' property
+in Emacs."
+ (if (and (macro-function symbol)
+ (not (known-to-emacs-p symbol)))
+ (let ((arglist (arglist symbol)))
+ (etypecase arglist
+ ((member :not-available)
+ nil)
+ (list
+ (macro-indentation arglist))))
+ nil))
+
+(defun macro-indentation (arglist)
+ (if (well-formed-list-p arglist)
+ (position '&body (remove '&optional (clean-arglist arglist)))
+ nil))
+
+(defun clean-arglist (arglist)
+ "Remove &whole, &enviroment, and &aux elements from ARGLIST."
+ (cond ((null arglist) '())
+ ((member (car arglist) '(&whole &environment))
+ (clean-arglist (cddr arglist)))
+ ((eq (car arglist) '&aux)
+ '())
+ (t (cons (car arglist) (clean-arglist (cdr arglist))))))
+
+(defun well-formed-list-p (list)
+ "Is LIST a proper list terminated by NIL?"
+ (typecase list
+ (null t)
+ (cons (well-formed-list-p (cdr list)))
+ (t nil)))
+
+(defun print-indentation-lossage (&optional (stream *standard-output*))
+ "Return the list of symbols whose indentation styles collide incompatibly.
+Collisions are caused because package information is ignored."
+ (let ((table (make-hash-table :test 'equal)))
+ (flet ((name (s) (string-downcase (symbol-name s))))
+ (do-all-symbols (s)
+ (setf (gethash (name s) table)
+ (cons s (symbol-indentation s))))
+ (let ((collisions '()))
+ (do-all-symbols (s)
+ (let* ((entry (gethash (name s) table))
+ (owner (car entry))
+ (indent (cdr entry)))
+ (unless (or (eq s owner)
+ (equal (symbol-indentation s) indent)
+ (and (not (fboundp s))
+ (null (macro-function s))))
+ (pushnew owner collisions)
+ (pushnew s collisions))))
+ (if (null collisions)
+ (format stream "~&No worries!~%")
+ (format stream "~&Symbols with collisions:~%~{ ~S~%~}"
+ collisions))))))
+
+;;; FIXME: it's too slow on CLASP right now, remove once it's fast enough.
+#-clasp
+(add-hook *pre-reply-hook* 'sync-indentation-to-emacs)
+
+
+;;;; Testing
+
+(defslimefun io-speed-test (&optional (n 1000) (m 1))
+ (let* ((s *standard-output*)
+ (*trace-output* (make-broadcast-stream s *log-output*)))
+ (time (progn
+ (dotimes (i n)
+ (format s "~D abcdefghijklm~%" i)
+ (when (zerop (mod n m))
+ (finish-output s)))
+ (finish-output s)
+ (when *emacs-connection*
+ (eval-in-emacs '(message "done.")))))
+ (terpri *trace-output*)
+ (finish-output *trace-output*)
+ nil))
+
+(defslimefun flow-control-test (n delay)
+ (let ((stream (make-output-stream
+ (let ((conn *emacs-connection*))
+ (lambda (string)
+ (declare (ignore string))
+ (with-connection (conn)
+ (send-to-emacs `(:test-delay ,delay))))))))
+ (dotimes (i n)
+ (print i stream)
+ (force-output stream)
+ (background-message "flow-control-test: ~d" i))))
+
+
+(defun before-init (version load-path)
+ (pushnew :swank *features*)
+ (setq *swank-wire-protocol-version* version)
+ (setq *load-path* load-path))
+
+(defun init ()
+ (run-hook *after-init-hook*))
+
+;; Local Variables:
+;; coding: latin-1-unix
+;; indent-tabs-mode: nil
+;; outline-regexp: ";;;;;*"
+;; End:
+
+;;; swank.lisp ends here
diff --git a/vim/bundle/slimv/slime/swank/abcl.lisp b/vim/bundle/slimv/slime/swank/abcl.lisp
new file mode 100644
index 0000000..f5764d6
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/abcl.lisp
@@ -0,0 +1,847 @@
+;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
+;;;
+;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
+;;;
+;;; Adapted from swank-acl.lisp, Andras Simon, 2004
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(defpackage swank/abcl
+ (:use cl swank/backend))
+
+(in-package swank/abcl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :collect) ;just so that it doesn't spoil the flying letters
+ (require :pprint)
+ (require :gray-streams)
+ (assert (>= (read-from-string (subseq (lisp-implementation-version) 0 4))
+ 0.22)
+ () "This file needs ABCL version 0.22 or newer"))
+
+(defimplementation gray-package-name ()
+ "GRAY-STREAMS")
+
+;; FIXME: switch to shared Gray stream implementation when bugs are
+;; fixed in ABCL. See: http://abcl.org/trac/ticket/373.
+(progn
+ (defimplementation make-output-stream (write-string)
+ (ext:make-slime-output-stream write-string))
+
+ (defimplementation make-input-stream (read-string)
+ (ext:make-slime-input-stream read-string
+ (make-synonym-stream '*standard-output*))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (funcall function))
+
+;;; swank-mop
+
+;;dummies and definition
+
+(defclass standard-slot-definition ()())
+
+;(defun class-finalized-p (class) t)
+
+(defun slot-definition-documentation (slot)
+ (declare (ignore slot))
+ #+nil (documentation slot 't))
+
+(defun slot-definition-type (slot)
+ (declare (ignore slot))
+ t)
+
+(defun class-prototype (class)
+ (declare (ignore class))
+ nil)
+
+(defun generic-function-declarations (gf)
+ (declare (ignore gf))
+ nil)
+
+(defun specializer-direct-methods (spec)
+ (mop:class-direct-methods spec))
+
+(defun slot-definition-name (slot)
+ (mop:slot-definition-name slot))
+
+(defun class-slots (class)
+ (mop:class-slots class))
+
+(defun method-generic-function (method)
+ (mop:method-generic-function method))
+
+(defun method-function (method)
+ (mop:method-function method))
+
+(defun slot-boundp-using-class (class object slotdef)
+ (declare (ignore class))
+ (system::slot-boundp object (slot-definition-name slotdef)))
+
+(defun slot-value-using-class (class object slotdef)
+ (declare (ignore class))
+ (system::slot-value object (slot-definition-name slotdef)))
+
+(import-to-swank-mop
+ '( ;; classes
+ cl:standard-generic-function
+ standard-slot-definition ;;dummy
+ cl:method
+ cl:standard-class
+ #+#.(swank/backend:with-symbol 'compute-applicable-methods-using-classes
+ 'mop)
+ mop:compute-applicable-methods-using-classes
+ ;; standard-class readers
+ mop:class-default-initargs
+ mop:class-direct-default-initargs
+ mop:class-direct-slots
+ mop:class-direct-subclasses
+ mop:class-direct-superclasses
+ mop:eql-specializer
+ mop:class-finalized-p
+ mop:finalize-inheritance
+ cl:class-name
+ mop:class-precedence-list
+ class-prototype ;;dummy
+ class-slots
+ specializer-direct-methods
+ ;; eql-specializer accessors
+ mop::eql-specializer-object
+ ;; generic function readers
+ mop:generic-function-argument-precedence-order
+ generic-function-declarations ;;dummy
+ mop:generic-function-lambda-list
+ mop:generic-function-methods
+ mop:generic-function-method-class
+ mop:generic-function-method-combination
+ mop:generic-function-name
+ ;; method readers
+ method-generic-function
+ method-function
+ mop:method-lambda-list
+ mop:method-specializers
+ mop:method-qualifiers
+ ;; slot readers
+ mop:slot-definition-allocation
+ slot-definition-documentation ;;dummy
+ mop:slot-definition-initargs
+ mop:slot-definition-initform
+ mop:slot-definition-initfunction
+ slot-definition-name
+ slot-definition-type ;;dummy
+ mop:slot-definition-readers
+ mop:slot-definition-writers
+ slot-boundp-using-class
+ slot-value-using-class
+ mop:slot-makunbound-using-class))
+
+;;;; TCP Server
+
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defimplementation create-socket (host port &key backlog)
+ (ext:make-server-socket port))
+
+(defimplementation local-port (socket)
+ (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
+
+(defimplementation close-socket (socket)
+ (ext:server-socket-close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout))
+ (ext:get-socket-stream (ext:socket-accept socket)
+ :element-type (if external-format
+ 'character
+ '(unsigned-byte 8))
+ :external-format (or external-format :default)))
+
+;;;; UTF8
+
+;; faster please!
+(defimplementation string-to-utf8 (s)
+ (jbytes-to-octets
+ (java:jcall
+ (java:jmethod "java.lang.String" "getBytes" "java.lang.String")
+ s
+ "UTF8")))
+
+(defimplementation utf8-to-string (u)
+ (java:jnew
+ (java:jconstructor "org.armedbear.lisp.SimpleString"
+ "java.lang.String")
+ (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String")
+ (octets-to-jbytes u)
+ "UTF8")))
+
+(defun octets-to-jbytes (octets)
+ (declare (type octets (simple-array (unsigned-byte 8) (*))))
+ (let* ((len (length octets))
+ (bytes (java:jnew-array "byte" len)))
+ (loop for byte across octets
+ for i from 0
+ do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte"
+ "java.lang.Object" "int" "byte")
+ "java.lang.relect.Array"
+ bytes i byte))
+ bytes))
+
+(defun jbytes-to-octets (jbytes)
+ (let* ((len (java:jarray-length jbytes))
+ (octets (make-array len :element-type '(unsigned-byte 8))))
+ (loop for i from 0 below len
+ for jbyte = (java:jarray-ref jbytes i)
+ do (setf (aref octets i) jbyte))
+ octets))
+
+;;;; External formats
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
+ ((:iso-8859-1 :eol-style :lf)
+ "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
+ (:utf-8 "utf-8")
+ ((:utf-8 :eol-style :lf) "utf-8-unix")
+ (:euc-jp "euc-jp")
+ ((:euc-jp :eol-style :lf) "euc-jp-unix")
+ (:us-ascii "us-ascii")
+ ((:us-ascii :eol-style :lf) "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x)
+ (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+;;;; Unix signals
+
+(defimplementation getpid ()
+ (handler-case
+ (let* ((runtime
+ (java:jstatic "getRuntime" "java.lang.Runtime"))
+ (command
+ (java:jnew-array-from-array
+ "java.lang.String" #("sh" "-c" "echo $PPID")))
+ (runtime-exec-jmethod
+ ;; Complicated because java.lang.Runtime.exec() is
+ ;; overloaded on a non-primitive type (array of
+ ;; java.lang.String), so we have to use the actual
+ ;; parameter instance to get java.lang.Class
+ (java:jmethod "java.lang.Runtime" "exec"
+ (java:jcall
+ (java:jmethod "java.lang.Object" "getClass")
+ command)))
+ (process
+ (java:jcall runtime-exec-jmethod runtime command))
+ (output
+ (java:jcall (java:jmethod "java.lang.Process" "getInputStream")
+ process)))
+ (java:jcall (java:jmethod "java.lang.Process" "waitFor")
+ process)
+ (loop :with b :do
+ (setq b
+ (java:jcall (java:jmethod "java.io.InputStream" "read")
+ output))
+ :until (member b '(-1 #x0a)) ; Either EOF or LF
+ :collecting (code-char b) :into result
+ :finally (return
+ (parse-integer (coerce result 'string)))))
+ (t () 0)))
+
+(defimplementation lisp-implementation-type-name ()
+ "armedbear")
+
+(defimplementation set-default-directory (directory)
+ (let ((dir (sys::probe-directory directory)))
+ (when dir (setf *default-pathname-defaults* dir))
+ (namestring dir)))
+
+
+;;;; Misc
+
+(defimplementation arglist (fun)
+ (cond ((symbolp fun)
+ (multiple-value-bind (arglist present)
+ (sys::arglist fun)
+ (when (and (not present)
+ (fboundp fun)
+ (typep (symbol-function fun)
+ 'standard-generic-function))
+ (setq arglist
+ (mop::generic-function-lambda-list (symbol-function fun))
+ present
+ t))
+ (if present arglist :not-available)))
+ (t :not-available)))
+
+(defimplementation function-name (function)
+ (nth-value 2 (function-lambda-expression function)))
+
+(defimplementation macroexpand-all (form &optional env)
+ (ext:macroexpand-all form env))
+
+(defimplementation collect-macro-forms (form &optional env)
+ ;; Currently detects only normal macros, not compiler macros.
+ (declare (ignore env))
+ (with-collected-macro-forms (macro-forms)
+ (handler-bind ((warning #'muffle-warning))
+ (ignore-errors
+ (compile nil `(lambda () ,(macroexpand-all form env)))))
+ (values macro-forms nil)))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (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
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ ((:variable :macro)
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+
+;;;; Debugger
+
+;; Copied from swank-sbcl.lisp.
+;;
+;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*,
+;; so we have to make sure that the latter gets run when it was
+;; established locally by a user (i.e. changed meanwhile.)
+(defun make-invoke-debugger-hook (hook)
+ (lambda (condition old-hook)
+ (if *debugger-hook*
+ (funcall *debugger-hook* condition old-hook)
+ (funcall hook condition old-hook))))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
+ (funcall fun)))
+
+(defimplementation install-debugger-globally (function)
+ (setq *debugger-hook* function)
+ (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
+
+(defvar *sldb-topframe*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank))
+ (*sldb-topframe*
+ (second (member magic-token (sys:backtrace)
+ :key (lambda (frame)
+ (first (sys:frame-to-list frame)))))))
+ (funcall debugger-loop-fn)))
+
+(defun backtrace (start end)
+ "A backtrace without initial SWANK frames."
+ (let ((backtrace (sys:backtrace)))
+ (subseq (or (member *sldb-topframe* backtrace) backtrace)
+ start end)))
+
+(defun nth-frame (index)
+ (nth index (backtrace 0 nil)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (backtrace start end)))
+
+(defimplementation print-frame (frame stream)
+ (write-string (sys:frame-to-string frame)
+ stream))
+
+;;; Sorry, but can't seem to declare DEFIMPLEMENTATION under FLET.
+;;; --ME 20150403
+(defun nth-frame-list (index)
+ (java:jcall "toLispList" (nth-frame index)))
+
+(defun match-lambda (operator values)
+ (jvm::match-lambda-list
+ (multiple-value-list
+ (jvm::parse-lambda-list (ext:arglist operator)))
+ values))
+
+(defimplementation frame-locals (index)
+ (loop
+ :for id :upfrom 0
+ :with frame = (nth-frame-list index)
+ :with operator = (first frame)
+ :with values = (rest frame)
+ :with arglist = (if (and operator (consp values) (not (null values)))
+ (handler-case
+ (match-lambda operator values)
+ (jvm::lambda-list-mismatch (e)
+ :lambda-list-mismatch))
+ :not-available)
+ :for value :in values
+ :collecting (list
+ :name (if (not (keywordp arglist))
+ (first (nth id arglist))
+ (format nil "arg~A" id))
+ :id id
+ :value value)))
+
+(defimplementation frame-var-value (index id)
+ (elt (rest (java:jcall "toLispList" (nth-frame index))) id))
+
+
+#+nil
+(defimplementation disassemble-frame (index)
+ (disassemble (debugger:frame-function (nth-frame index))))
+
+(defimplementation frame-source-location (index)
+ (let ((frame (nth-frame index)))
+ (or (source-location (nth-frame index))
+ `(:error ,(format nil "No source for frame: ~a" frame)))))
+
+#+nil
+(defimplementation eval-in-frame (form frame-number)
+ (debugger:eval-form-in-context
+ form
+ (debugger:environment-of-frame (nth-frame frame-number))))
+
+#+nil
+(defimplementation return-from-frame (frame-number form)
+ (let ((frame (nth-frame frame-number)))
+ (multiple-value-call #'debugger:frame-return
+ frame (debugger:eval-form-in-context
+ form
+ (debugger:environment-of-frame frame)))))
+
+;;; XXX doesn't work for frames with arguments
+#+nil
+(defimplementation restart-frame (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (debugger:frame-retry frame (debugger:frame-function frame))))
+
+;;;; Compiler hooks
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename*)
+
+(defvar *abcl-signaled-conditions*)
+
+(defun handle-compiler-warning (condition)
+ (let ((loc (when (and jvm::*compile-file-pathname*
+ system::*source-position*)
+ (cons jvm::*compile-file-pathname* system::*source-position*))))
+ ;; filter condition signaled more than once.
+ (unless (member condition *abcl-signaled-conditions*)
+ (push condition *abcl-signaled-conditions*)
+ (signal 'compiler-condition
+ :original-condition condition
+ :severity :warning
+ :message (format nil "~A" condition)
+ :location (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* 0)))
+ (loc
+ (destructuring-bind (file . pos) loc
+ (make-location
+ (list :file (namestring (truename file)))
+ (list :position (1+ pos)))))
+ (t
+ (make-location
+ (list :file (namestring *compile-filename*))
+ (list :position 1))))))))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore external-format policy))
+ (let ((jvm::*resignal-compiler-warnings* t)
+ (*abcl-signaled-conditions* nil))
+ (handler-bind ((warning #'handle-compiler-warning))
+ (let ((*buffer-name* nil)
+ (*compile-filename* input-file))
+ (multiple-value-bind (fn warn fail)
+ (compile-file input-file :output-file output-file)
+ (values fn warn
+ (and fn load-p
+ (not (load fn)))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore filename policy))
+ (let ((jvm::*resignal-compiler-warnings* t)
+ (*abcl-signaled-conditions* nil))
+ (handler-bind ((warning #'handle-compiler-warning))
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-string* string)
+ (sys::*source* (make-pathname :device "emacs-buffer" :name buffer))
+ (sys::*source-position* position))
+ (funcall (compile nil (read-from-string
+ (format nil "(~S () ~A)" 'lambda string))))
+ t))))
+
+#|
+;;;; Definition Finding
+
+(defun find-fspec-location (fspec type)
+ (let ((file (excl::fspec-pathname fspec type)))
+ (etypecase file
+ (pathname
+ (let ((start (scm:find-definition-in-file fspec type file)))
+ (make-location (list :file (namestring (truename file)))
+ (if start
+ (list :position (1+ start))
+ (list :function-name (string fspec))))))
+ ((member :top-level)
+ (list :error (format nil "Defined at toplevel: ~A" fspec)))
+ (null
+ (list :error (format nil "Unkown source location for ~A" fspec))))))
+
+(defun fspec-definition-locations (fspec)
+ (let ((defs (excl::find-multiple-definitions fspec)))
+ (loop for (fspec type) in defs
+ collect (list fspec (find-fspec-location fspec type)))))
+
+(defimplementation find-definitions (symbol)
+ (fspec-definition-locations symbol))
+|#
+
+(defgeneric source-location (object))
+
+(defmethod source-location ((symbol symbol))
+ (when (pathnamep (ext:source-pathname symbol))
+ (let ((pos (ext:source-file-position symbol))
+ (path (namestring (ext:source-pathname symbol))))
+ (cond ((ext:pathname-jar-p path)
+ `(:location
+ ;; strip off "jar:file:" = 9 characters
+ (:zip ,@(split-string (subseq path 9) "!/"))
+ ;; pos never seems right. Use function name.
+ (:function-name ,(string symbol))
+ (:align t)))
+ ((equal (pathname-device (ext:source-pathname symbol)) "emacs-buffer")
+ ;; conspire with swank-compile-string to keep the buffer
+ ;; name in a pathname whose device is "emacs-buffer".
+ `(:location
+ (:buffer ,(pathname-name (ext:source-pathname symbol)))
+ (:function-name ,(string symbol))
+ (:align t)))
+ (t
+ `(:location
+ (:file ,path)
+ ,(if pos
+ (list :position (1+ pos))
+ (list :function-name (string symbol)))
+ (:align t)))))))
+
+(defmethod source-location ((frame sys::java-stack-frame))
+ (destructuring-bind (&key class method file line) (sys:frame-to-list frame)
+ (declare (ignore method))
+ (let ((file (or (find-file-in-path file *source-path*)
+ (let ((f (format nil "~{~a/~}~a"
+ (butlast (split-string class "\\."))
+ file)))
+ (find-file-in-path f *source-path*)))))
+ (and file
+ `(:location ,file (:line ,line) ())))))
+
+(defmethod source-location ((frame sys::lisp-stack-frame))
+ (destructuring-bind (operator &rest args) (sys:frame-to-list frame)
+ (declare (ignore args))
+ (etypecase operator
+ (function (source-location operator))
+ (list nil)
+ (symbol (source-location operator)))))
+
+(defmethod source-location ((fun function))
+ (let ((name (function-name fun)))
+ (and name (source-location name))))
+
+(defun system-property (name)
+ (java:jstatic "getProperty" "java.lang.System" name))
+
+(defun pathname-parent (pathname)
+ (make-pathname :directory (butlast (pathname-directory pathname))))
+
+(defun pathname-absolute-p (pathname)
+ (eq (car (pathname-directory pathname)) ':absolute))
+
+(defun split-string (string regexp)
+ (coerce
+ (java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String")
+ string regexp)
+ 'list))
+
+(defun path-separator ()
+ (java:jfield "java.io.File" "pathSeparator"))
+
+(defun search-path-property (prop-name)
+ (let ((string (system-property prop-name)))
+ (and string
+ (remove nil
+ (mapcar #'truename
+ (split-string string (path-separator)))))))
+
+(defun jdk-source-path ()
+ (let* ((jre-home (truename (system-property "java.home")))
+ (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home)))
+ (truename (probe-file src-zip)))
+ (and truename (list truename))))
+
+(defun class-path ()
+ (append (search-path-property "java.class.path")
+ (search-path-property "sun.boot.class.path")))
+
+(defvar *source-path*
+ (append (search-path-property "user.dir")
+ (jdk-source-path)
+ ;;(list (truename "/scratch/abcl/src"))
+ )
+ "List of directories to search for source files.")
+
+(defun zipfile-contains-p (zipfile-name entry-name)
+ (let ((zipfile (java:jnew (java:jconstructor "java.util.zip.ZipFile"
+ "java.lang.String")
+ zipfile-name)))
+ (java:jcall
+ (java:jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String")
+ zipfile entry-name)))
+
+;; (find-file-in-path "java/lang/String.java" *source-path*)
+;; (find-file-in-path "Lisp.java" *source-path*)
+
+;; Try to find FILENAME in PATH. If found, return a file spec as
+;; needed by Emacs. We also look in zip files.
+(defun find-file-in-path (filename path)
+ (labels ((try (dir)
+ (cond ((not (pathname-type dir))
+ (let ((f (probe-file (merge-pathnames filename dir))))
+ (and f `(:file ,(namestring f)))))
+ ((equal (pathname-type dir) "zip")
+ (try-zip dir))
+ (t (error "strange path element: ~s" path))))
+ (try-zip (zip)
+ (let* ((zipfile-name (namestring (truename zip))))
+ (and (zipfile-contains-p zipfile-name filename)
+ `(:dir ,zipfile-name ,filename)))))
+ (cond ((pathname-absolute-p filename) (probe-file filename))
+ (t
+ (loop for dir in path
+ if (try dir) return it)))))
+
+(defimplementation find-definitions (symbol)
+ (ext:resolve symbol)
+ (let ((srcloc (source-location symbol)))
+ (and srcloc `((,symbol ,srcloc)))))
+
+#|
+Uncomment this if you have patched xref.lisp, as in
+http://article.gmane.org/gmane.lisp.slime.devel/2425
+Also, make sure that xref.lisp is loaded by modifying the armedbear
+part of *sysdep-pathnames* in swank.loader.lisp.
+
+;;;; XREF
+(setq pxref:*handle-package-forms* '(cl:in-package))
+
+(defmacro defxref (name function)
+ `(defimplementation ,name (name)
+ (xref-results (,function name))))
+
+(defxref who-calls pxref:list-callers)
+(defxref who-references pxref:list-readers)
+(defxref who-binds pxref:list-setters)
+(defxref who-sets pxref:list-setters)
+(defxref list-callers pxref:list-callers)
+(defxref list-callees pxref:list-callees)
+
+(defun xref-results (symbols)
+ (let ((xrefs '()))
+ (dolist (symbol symbols)
+ (push (list symbol (cadar (source-location symbol))) xrefs))
+ xrefs))
+|#
+
+;;;; Inspecting
+(defmethod emacs-inspect ((o t))
+ (let ((parts (sys:inspected-parts o)))
+ `("The object is of type " ,(symbol-name (type-of o)) "." (:newline)
+ ,@(if parts
+ (loop :for (label . value) :in parts
+ :appending (label-value-line label value))
+ (list "No inspectable parts, dumping output of CL:DESCRIBE:"
+ '(:newline)
+ (with-output-to-string (desc) (describe o desc)))))))
+
+(defmethod emacs-inspect ((slot mop::slot-definition))
+ `("Name: "
+ (:value ,(mop:slot-definition-name slot))
+ (:newline)
+ "Documentation:" (:newline)
+ ,@(when (slot-definition-documentation slot)
+ `((:value ,(slot-definition-documentation slot)) (:newline)))
+ "Initialization:" (:newline)
+ " Args: " (:value ,(mop:slot-definition-initargs slot)) (:newline)
+ " Form: " ,(if (mop:slot-definition-initfunction slot)
+ `(:value ,(mop:slot-definition-initform slot))
+ "#<unspecified>") (:newline)
+ " Function: "
+ (:value ,(mop:slot-definition-initfunction slot))
+ (:newline)))
+
+(defmethod emacs-inspect ((f function))
+ `(,@(when (function-name f)
+ `("Name: "
+ ,(princ-to-string (function-name f)) (:newline)))
+ ,@(multiple-value-bind (args present)
+ (sys::arglist f)
+ (when present
+ `("Argument list: "
+ ,(princ-to-string args) (:newline))))
+ (:newline)
+ #+nil,@(when (documentation f t)
+ `("Documentation:" (:newline)
+ ,(documentation f t) (:newline)))
+ ,@(when (function-lambda-expression f)
+ `("Lambda expression:"
+ (:newline) ,(princ-to-string
+ (function-lambda-expression f)) (:newline)))))
+
+;;; Although by convention toString() is supposed to be a
+;;; non-computationally expensive operation this isn't always the
+;;; case, so make its computation a user interaction.
+(defparameter *to-string-hashtable* (make-hash-table))
+(defmethod emacs-inspect ((o java:java-object))
+ (let ((to-string (lambda ()
+ (handler-case
+ (setf (gethash o *to-string-hashtable*)
+ (java:jcall "toString" o))
+ (t (e)
+ (setf (gethash o *to-string-hashtable*)
+ (format nil
+ "Could not invoke toString(): ~A"
+ e)))))))
+ (append
+ (if (gethash o *to-string-hashtable*)
+ (label-value-line "toString()" (gethash o *to-string-hashtable*))
+ `((:action "[compute toString()]" ,to-string) (:newline)))
+ (loop :for (label . value) :in (sys:inspected-parts o)
+ :appending (label-value-line label value)))))
+
+;;;; Multithreading
+
+(defimplementation spawn (fn &key name)
+ (threads:make-thread (lambda () (funcall fn)) :name name))
+
+(defvar *thread-plists* (make-hash-table) ; should be a weak table
+ "A hashtable mapping threads to a plist.")
+
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (threads:synchronized-on *thread-plists*
+ (or (getf (gethash thread *thread-plists*) 'id)
+ (setf (getf (gethash thread *thread-plists*) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (find id (all-threads)
+ :key (lambda (thread)
+ (getf (gethash thread *thread-plists*) 'id))))
+
+(defimplementation thread-name (thread)
+ (threads:thread-name thread))
+
+(defimplementation thread-status (thread)
+ (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
+
+(defimplementation make-lock (&key name)
+ (declare (ignore name))
+ (threads:make-thread-lock))
+
+(defimplementation call-with-lock-held (lock function)
+ (threads:with-thread-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ (threads:current-thread))
+
+(defimplementation all-threads ()
+ (copy-list (threads:mapcar-threads #'identity)))
+
+(defimplementation thread-alive-p (thread)
+ (member thread (all-threads)))
+
+(defimplementation interrupt-thread (thread fn)
+ (threads:interrupt-thread thread fn))
+
+(defimplementation kill-thread (thread)
+ (threads:destroy-thread thread))
+
+(defstruct mailbox
+ (queue '()))
+
+(defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (threads:synchronized-on *thread-plists*
+ (or (getf (gethash thread *thread-plists*) 'mailbox)
+ (setf (getf (gethash thread *thread-plists*) 'mailbox)
+ (make-mailbox)))))
+
+(defimplementation send (thread message)
+ (let ((mbox (mailbox thread)))
+ (threads:synchronized-on mbox
+ (setf (mailbox-queue mbox)
+ (nconc (mailbox-queue mbox) (list message)))
+ (threads:object-notify-all mbox))))
+
+(defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox (current-thread))))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (threads:synchronized-on mbox
+ (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)))
+ (threads:object-wait mbox 0.3))))))
+
+(defimplementation quit-lisp ()
+ (ext:exit))
+;;;
+#+#.(swank/backend:with-symbol 'package-local-nicknames 'ext)
+(defimplementation package-local-nicknames (package)
+ (ext:package-local-nicknames package))
diff --git a/vim/bundle/slimv/slime/swank/allegro.lisp b/vim/bundle/slimv/slime/swank/allegro.lisp
new file mode 100644
index 0000000..f5918da
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/allegro.lisp
@@ -0,0 +1,1053 @@
+;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
+;;;
+;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
+;;;
+;;; Created 2003
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(defpackage swank/allegro
+ (:use cl swank/backend))
+
+(in-package swank/allegro)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :sock)
+ (require :process)
+ #+(version>= 8 2)
+ (require 'lldb))
+
+(defimplementation gray-package-name ()
+ '#:excl)
+
+;;; swank-mop
+
+(import-swank-mop-symbols :clos '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (documentation slot t))
+
+
+;;;; UTF8
+
+(define-symbol-macro utf8-ef
+ (load-time-value
+ (excl:crlf-base-ef (excl:find-external-format :utf-8))
+ t))
+
+(defimplementation string-to-utf8 (s)
+ (excl:string-to-octets s :external-format utf8-ef
+ :null-terminate nil))
+
+(defimplementation utf8-to-string (u)
+ (excl:octets-to-string u :external-format utf8-ef))
+
+
+;;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defimplementation create-socket (host port &key backlog)
+ (socket:make-socket :connect :passive :local-port port
+ :local-host host :reuse-address t
+ :backlog (or backlog 5)))
+
+(defimplementation local-port (socket)
+ (socket:local-port socket))
+
+(defimplementation close-socket (socket)
+ (close socket))
+
+(defimplementation accept-connection (socket &key external-format buffering
+ timeout)
+ (declare (ignore buffering timeout))
+ (let ((s (socket:accept-connection socket :wait t)))
+ (when external-format
+ (setf (stream-external-format s) external-format))
+ s))
+
+(defimplementation socket-fd (stream)
+ (excl::stream-input-handle stream))
+
+(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")
+ (:emacs-mule "emacs-mule" "emacs-mule-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+ (and e (excl:crlf-base-ef
+ (excl:find-external-format (car e)
+ :try-variant t)))))
+
+;;;; Unix signals
+
+(defimplementation getpid ()
+ (excl::getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "allegro")
+
+(defimplementation set-default-directory (directory)
+ (let* ((dir (namestring (truename (merge-pathnames directory)))))
+ (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
+ dir))
+
+(defimplementation default-directory ()
+ (namestring (excl:current-directory)))
+
+;;;; Misc
+
+(defimplementation arglist (symbol)
+ (handler-case (excl:arglist symbol)
+ (simple-error () :not-available)))
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ #+(version>= 8 0)
+ (excl::walk-form form)
+ #-(version>= 8 0)
+ (excl::walk form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :function (if (fboundp symbol)
+ (doc 'function)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+(defimplementation type-specifier-p (symbol)
+ (or (ignore-errors
+ (subtypep nil symbol))
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+(defimplementation function-name (f)
+ (check-type f function)
+ (cross-reference::object-to-function-name f))
+
+;;;; Debugger
+
+(defvar *sldb-topframe*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let ((*sldb-topframe* (find-topframe))
+ (excl::*break-hook* nil))
+ (funcall debugger-loop-fn)))
+
+(defimplementation sldb-break-at-start (fname)
+ ;; :print-before is kind of mis-used but we just want to stuff our
+ ;; break form somewhere. This does not work for setf, :before and
+ ;; :after methods, which need special syntax in the trace call, see
+ ;; ACL's doc/debugging.htm chapter 10.
+ (eval `(trace (,fname
+ :print-before
+ ((break "Function start breakpoint of ~A" ',fname)))))
+ `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
+
+(defun find-topframe ()
+ (let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
+ (find-package :swank)))
+ (top-frame (excl::int-newest-frame (excl::current-thread))))
+ (loop for frame = top-frame then (next-frame frame)
+ for i from 0
+ while (and frame (< i 30))
+ when (eq (debugger:frame-name frame) magic-symbol)
+ return (next-frame frame)
+ finally (return top-frame))))
+
+(defun next-frame (frame)
+ (let ((next (excl::int-next-older-frame frame)))
+ (cond ((not next) nil)
+ ((debugger:frame-visible-p next) next)
+ (t (next-frame next)))))
+
+(defun nth-frame (index)
+ (do ((frame *sldb-topframe* (next-frame frame))
+ (i index (1- i)))
+ ((zerop i) frame)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (loop for f = (nth-frame start) then (next-frame f)
+ for i from start below end
+ while f collect f)))
+
+(defimplementation print-frame (frame stream)
+ (debugger:output-frame stream frame :moderate))
+
+(defimplementation frame-locals (index)
+ (let ((frame (nth-frame index)))
+ (loop for i from 0 below (debugger:frame-number-vars frame)
+ collect (list :name (debugger:frame-var-name frame i)
+ :id 0
+ :value (debugger:frame-var-value frame i)))))
+
+(defimplementation frame-var-value (frame var)
+ (let ((frame (nth-frame frame)))
+ (debugger:frame-var-value frame var)))
+
+(defimplementation disassemble-frame (index)
+ (let ((frame (nth-frame index)))
+ (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
+ (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
+ (disassemble (debugger:frame-function frame)))))
+
+(defimplementation frame-source-location (index)
+ (let* ((frame (nth-frame index)))
+ (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
+ (declare (ignore x xx xxx))
+ (cond ((and pc
+ #+(version>= 8 2)
+ (pc-source-location fun pc)
+ #-(version>= 8 2)
+ (function-source-location fun)))
+ (t ; frames for unbound functions etc end up here
+ (cadr (car (fspec-definition-locations
+ (car (debugger:frame-expression frame))))))))))
+
+(defun function-source-location (fun)
+ (cadr (car (fspec-definition-locations
+ (xref::object-to-function-name fun)))))
+
+#+(version>= 8 2)
+(defun pc-source-location (fun pc)
+ (let* ((debug-info (excl::function-source-debug-info fun)))
+ (cond ((not debug-info)
+ (function-source-location fun))
+ (t
+ (let* ((code-loc (find-if (lambda (c)
+ (<= (- pc (sys::natural-width))
+ (let ((x (excl::ldb-code-pc c)))
+ (or x -1))
+ pc))
+ debug-info)))
+ (cond ((not code-loc)
+ (ldb-code-to-src-loc (aref debug-info 0)))
+ (t
+ (ldb-code-to-src-loc code-loc))))))))
+
+#+(version>= 8 2)
+(defun ldb-code-to-src-loc (code)
+ (declare (optimize debug))
+ (let* ((func (excl::ldb-code-func code))
+ (debug-info (excl::function-source-debug-info func))
+ (start (loop for i from (excl::ldb-code-index code) downto 0
+ for bpt = (aref debug-info i)
+ for start = (excl::ldb-code-start-char bpt)
+ when start return start))
+ (src-file (excl:source-file func)))
+ (cond (start
+ (buffer-or-file-location src-file start))
+ (func
+ (let* ((debug-info (excl::function-source-debug-info func))
+ (whole (aref debug-info 0))
+ (paths (source-paths-of (excl::ldb-code-source whole)
+ (excl::ldb-code-source code)))
+ (path (if paths (longest-common-prefix paths) '()))
+ (start 0))
+ (buffer-or-file
+ src-file
+ (lambda (file)
+ (make-location `(:file ,file)
+ `(:source-path (0 . ,path) ,start)))
+ (lambda (buffer bstart)
+ (make-location `(:buffer ,buffer)
+ `(:source-path (0 . ,path)
+ ,(+ bstart start)))))))
+ (t
+ nil))))
+
+(defun longest-common-prefix (sequences)
+ (assert sequences)
+ (flet ((common-prefix (s1 s2)
+ (let ((diff-pos (mismatch s1 s2)))
+ (if diff-pos (subseq s1 0 diff-pos) s1))))
+ (reduce #'common-prefix sequences)))
+
+(defun source-paths-of (whole part)
+ (let ((result '()))
+ (labels ((walk (form path)
+ (cond ((eq form part)
+ (push (reverse path) result))
+ ((consp form)
+ (loop for i from 0 while (consp form) do
+ (walk (pop form) (cons i path)))))))
+ (walk whole '())
+ (reverse result))))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((frame (nth-frame frame-number)))
+ ;; let-bind lexical variables
+ (let ((vars (loop for i below (debugger:frame-number-vars frame)
+ for name = (debugger:frame-var-name frame i)
+ if (typep name '(and symbol (not null) (not keyword)))
+ collect `(,name ',(debugger:frame-var-value frame i)))))
+ (debugger:eval-form-in-context
+ `(let* ,vars ,form)
+ (debugger:environment-of-frame frame)))))
+
+(defimplementation frame-package (frame-number)
+ (let* ((frame (nth-frame frame-number))
+ (exp (debugger:frame-expression frame)))
+ (typecase exp
+ ((cons symbol) (symbol-package (car exp)))
+ ((cons (cons (eql :internal) (cons symbol)))
+ (symbol-package (cadar exp))))))
+
+(defimplementation return-from-frame (frame-number form)
+ (let ((frame (nth-frame frame-number)))
+ (multiple-value-call #'debugger:frame-return
+ frame (debugger:eval-form-in-context
+ form
+ (debugger:environment-of-frame frame)))))
+
+(defimplementation frame-restartable-p (frame)
+ (handler-case (debugger:frame-retryable-p frame)
+ (serious-condition (c)
+ (funcall (read-from-string "swank::background-message")
+ "~a ~a" frame (princ-to-string c))
+ nil)))
+
+(defimplementation restart-frame (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (cond ((debugger:frame-retryable-p frame)
+ (apply #'debugger:frame-retry frame (debugger:frame-function frame)
+ (cdr (debugger:frame-expression frame))))
+ (t "Frame is not retryable"))))
+
+;;;; Compiler hooks
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename* nil)
+
+(defun compiler-note-p (object)
+ (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
+
+(defun redefinition-p (condition)
+ (and (typep condition 'style-warning)
+ (every #'char-equal "redefin" (princ-to-string condition))))
+
+(defun compiler-undefined-functions-called-warning-p (object)
+ (typep object 'excl:compiler-undefined-functions-called-warning))
+
+(deftype compiler-note ()
+ `(satisfies compiler-note-p))
+
+(deftype redefinition ()
+ `(satisfies redefinition-p))
+
+(defun signal-compiler-condition (&rest args)
+ (apply #'signal 'compiler-condition args))
+
+(defun handle-compiler-warning (condition)
+ (declare (optimize (debug 3) (speed 0) (space 0)))
+ (cond ((and #-(version>= 10 0) (not *buffer-name*)
+ (compiler-undefined-functions-called-warning-p condition))
+ (handle-undefined-functions-warning condition))
+ ((and (typep condition 'excl::compiler-note)
+ (let ((format (slot-value condition 'excl::format-control)))
+ (and (search "Closure" format)
+ (search "will be stack allocated" format))))
+ ;; Ignore "Closure <foo> will be stack allocated" notes.
+ ;; That occurs often but is usually uninteresting.
+ )
+ (t
+ (signal-compiler-condition
+ :original-condition condition
+ :severity (etypecase condition
+ (redefinition :redefinition)
+ (style-warning :style-warning)
+ (warning :warning)
+ (compiler-note :note)
+ (reader-error :read-error)
+ (error :error))
+ :message (format nil "~A" condition)
+ :location (compiler-warning-location condition)))))
+
+(defun condition-pathname-and-position (condition)
+ (let* ((context #+(version>= 10 0)
+ (getf (slot-value condition 'excl::plist)
+ :source-context))
+ (location-available (and context
+ (excl::source-context-start-char context))))
+ (cond (location-available
+ (values (excl::source-context-pathname context)
+ (when-let (start-char (excl::source-context-start-char context))
+ (1+ (if (listp start-char) ; HACK
+ (first start-char)
+ start-char)))))
+ ((typep condition 'reader-error)
+ (let ((pos (car (last (slot-value condition 'excl::format-arguments))))
+ (file (pathname (stream-error-stream condition))))
+ (when (integerp pos)
+ (values file pos))))
+ (t
+ (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
+ (when loc
+ (destructuring-bind (file . pos) loc
+ (let ((start (if (consp pos) ; 8.2 and newer
+ (car pos)
+ pos)))
+ (values file (1+ start))))))))))
+
+(defun compiler-warning-location (condition)
+ (multiple-value-bind (pathname position)
+ (condition-pathname-and-position condition)
+ (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (if position
+ (list :position position)
+ (list :offset *buffer-start-position* 0))))
+ (pathname
+ (make-location
+ (list :file (namestring (truename pathname)))
+ (list :position position)))
+ (t
+ (make-error-location "No error location available.")))))
+
+;; TODO: report it as a bug to Franz that the condition's plist
+;; slot contains (:loc nil).
+(defun handle-undefined-functions-warning (condition)
+ (let ((fargs (slot-value condition 'excl::format-arguments)))
+ (loop for (fname . locs) in (car fargs) do
+ (dolist (loc locs)
+ (multiple-value-bind (pos file) (ecase (length loc)
+ (2 (values-list loc))
+ (3 (destructuring-bind
+ (start end file) loc
+ (declare (ignore end))
+ (values start file))))
+ (signal-compiler-condition
+ :original-condition condition
+ :severity :warning
+ :message (format nil "Undefined function referenced: ~S"
+ fname)
+ :location (make-location (list :file file)
+ (list :position (1+ pos)))))))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((warning #'handle-compiler-warning)
+ (compiler-note #'handle-compiler-warning)
+ (reader-error #'handle-compiler-warning))
+ (funcall function)))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (handler-case
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (*compile-filename* input-file)
+ #+(version>= 8 2)
+ (compiler:save-source-level-debug-info-switch t)
+ (excl:*load-source-file-info* t)
+ #+(version>= 8 2)
+ (excl:*load-source-debug-info* t))
+ (compile-file *compile-filename*
+ :output-file output-file
+ :load-after-compile load-p
+ :external-format external-format)))
+ (reader-error () (values nil nil t))))
+
+(defun call-with-temp-file (fn)
+ (let ((tmpname (system:make-temp-file-name)))
+ (unwind-protect
+ (with-open-file (file tmpname :direction :output :if-exists :error)
+ (funcall fn file tmpname))
+ (delete-file tmpname))))
+
+(defvar *temp-file-map* (make-hash-table :test #'equal)
+ "A mapping from tempfile names to Emacs buffer names.")
+
+(defun write-tracking-preamble (stream file file-offset)
+ "Instrument the top of the temporary file to be compiled.
+
+The header tells allegro that any definitions compiled in the temp
+file should be found in FILE exactly at FILE-OFFSET. To get Allegro
+to do this, this factors in the length of the inserted header itself."
+ (with-standard-io-syntax
+ (let* ((*package* (find-package :keyword))
+ (source-pathname-form
+ `(cl:eval-when (:compile-toplevel :load-toplevel :execute)
+ (cl:setq excl::*source-pathname*
+ (pathname ,(sys::frob-source-file file)))))
+ (source-pathname-string (write-to-string source-pathname-form))
+ (position-form-length-bound 160) ; should be enough for everyone
+ (header-length (+ (length source-pathname-string)
+ position-form-length-bound))
+ (position-form
+ `(cl:eval-when (:compile-toplevel :load-toplevel :execute)
+ (cl:setq excl::*partial-source-file-p* ,(- file-offset
+ header-length
+ 1 ; for the newline
+ ))))
+ (position-form-string (write-to-string position-form))
+ (padding-string (make-string (- position-form-length-bound
+ (length position-form-string))
+ :initial-element #\;)))
+ (write-string source-pathname-string stream)
+ (write-string position-form-string stream)
+ (write-string padding-string stream)
+ (write-char #\newline stream))))
+
+(defun compile-from-temp-file (string buffer offset file)
+ (call-with-temp-file
+ (lambda (stream filename)
+ (when (and file offset (probe-file file))
+ (write-tracking-preamble stream file offset))
+ (write-string string stream)
+ (finish-output stream)
+ (multiple-value-bind (binary-filename warnings? failure?)
+ (let ((sys:*source-file-types* '(nil)) ; suppress .lisp extension
+ #+(version>= 8 2)
+ (compiler:save-source-level-debug-info-switch t)
+ (excl:*redefinition-warnings* nil))
+ (compile-file filename))
+ (declare (ignore warnings?))
+ (when binary-filename
+ (let ((excl:*load-source-file-info* t)
+ #+(version>= 8 2)
+ (excl:*load-source-debug-info* t))
+ excl::*source-pathname*
+ (load binary-filename))
+ (when (and buffer offset (or (not file)
+ (not (probe-file file))))
+ (setf (gethash (pathname stream) *temp-file-map*)
+ (list buffer offset)))
+ (delete-file binary-filename))
+ (not failure?)))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore policy))
+ (handler-case
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-string* string))
+ (compile-from-temp-file string buffer position filename)))
+ (reader-error () nil)))
+
+;;;; Definition Finding
+
+(defun buffer-or-file (file file-fun buffer-fun)
+ (let* ((probe (gethash file *temp-file-map*)))
+ (cond (probe
+ (destructuring-bind (buffer start) probe
+ (funcall buffer-fun buffer start)))
+ (t (funcall file-fun (namestring (truename file)))))))
+
+(defun buffer-or-file-location (file offset)
+ (buffer-or-file file
+ (lambda (filename)
+ (make-location `(:file ,filename)
+ `(:position ,(1+ offset))))
+ (lambda (buffer start)
+ (make-location `(:buffer ,buffer)
+ `(:offset ,start ,offset)))))
+
+(defun fspec-primary-name (fspec)
+ (etypecase fspec
+ (symbol fspec)
+ (list (fspec-primary-name (second fspec)))))
+
+(defun find-definition-in-file (fspec type file top-level)
+ (let* ((part
+ (or (scm::find-definition-in-definition-group
+ fspec type (scm:section-file :file file)
+ :top-level top-level)
+ (scm::find-definition-in-definition-group
+ (fspec-primary-name fspec)
+ type (scm:section-file :file file)
+ :top-level top-level)))
+ (start (and part
+ (scm::source-part-start part)))
+ (pos (if start
+ (list :position (1+ start))
+ (list :function-name (string (fspec-primary-name fspec))))))
+ (make-location (list :file (namestring (truename file)))
+ pos)))
+
+(defun find-fspec-location (fspec type file top-level)
+ (handler-case
+ (etypecase file
+ (pathname
+ (let ((probe (gethash file *temp-file-map*)))
+ (cond (probe
+ (destructuring-bind (buffer offset) probe
+ (make-location `(:buffer ,buffer)
+ `(:offset ,offset 0))))
+ (t
+ (find-definition-in-file fspec type file top-level)))))
+ ((member :top-level)
+ (make-error-location "Defined at toplevel: ~A"
+ (fspec->string fspec))))
+ (error (e)
+ (make-error-location "Error: ~A" e))))
+
+(defun fspec->string (fspec)
+ (typecase fspec
+ (symbol (let ((*package* (find-package :keyword)))
+ (prin1-to-string fspec)))
+ (list (format nil "(~A ~A)"
+ (prin1-to-string (first fspec))
+ (let ((*package* (find-package :keyword)))
+ (prin1-to-string (second fspec)))))
+ (t (princ-to-string fspec))))
+
+(defun fspec-definition-locations (fspec)
+ (cond
+ ((and (listp fspec) (eq (car fspec) :internal))
+ (destructuring-bind (_internal next _n) fspec
+ (declare (ignore _internal _n))
+ (fspec-definition-locations next)))
+ (t
+ (let ((defs (excl::find-source-file fspec)))
+ (when (and (null defs)
+ (listp fspec)
+ (string= (car fspec) '#:method))
+ ;; If methods are defined in a defgeneric form, the source location is
+ ;; recorded for the gf but not for the methods. Therefore fall back to
+ ;; the gf as the likely place of definition.
+ (setq defs (excl::find-source-file (second fspec))))
+ (if (null defs)
+ (list
+ (list fspec
+ (make-error-location "Unknown source location for ~A"
+ (fspec->string fspec))))
+ (loop for (fspec type file top-level) in defs collect
+ (list (list type fspec)
+ (find-fspec-location fspec type file top-level))))))))
+
+(defimplementation find-definitions (symbol)
+ (fspec-definition-locations symbol))
+
+(defimplementation find-source-location (obj)
+ (first (rest (first (fspec-definition-locations obj)))))
+
+;;;; XREF
+
+(defmacro defxref (name relation name1 name2)
+ `(defimplementation ,name (x)
+ (xref-result (xref:get-relation ,relation ,name1 ,name2))))
+
+(defxref who-calls :calls :wild x)
+(defxref calls-who :calls x :wild)
+(defxref who-references :uses :wild x)
+(defxref who-binds :binds :wild x)
+(defxref who-macroexpands :macro-calls :wild x)
+(defxref who-sets :sets :wild x)
+
+(defun xref-result (fspecs)
+ (loop for fspec in fspecs
+ append (fspec-definition-locations fspec)))
+
+;; list-callers implemented by groveling through all fbound symbols.
+;; Only symbols are considered. Functions in the constant pool are
+;; searched recursively. Closure environments are ignored at the
+;; moment (constants in methods are therefore not found).
+
+(defun map-function-constants (function fn depth)
+ "Call FN with the elements of FUNCTION's constant pool."
+ (do ((i 0 (1+ i))
+ (max (excl::function-constant-count function)))
+ ((= i max))
+ (let ((c (excl::function-constant function i)))
+ (cond ((and (functionp c)
+ (not (eq c function))
+ (plusp depth))
+ (map-function-constants c fn (1- depth)))
+ (t
+ (funcall fn c))))))
+
+(defun in-constants-p (fun symbol)
+ (map-function-constants fun
+ (lambda (c)
+ (when (eq c symbol)
+ (return-from in-constants-p t)))
+ 3))
+
+(defun function-callers (name)
+ (let ((callers '()))
+ (do-all-symbols (sym)
+ (when (fboundp sym)
+ (let ((fn (fdefinition sym)))
+ (when (in-constants-p fn name)
+ (push sym callers)))))
+ callers))
+
+(defimplementation list-callers (name)
+ (xref-result (function-callers name)))
+
+(defimplementation list-callees (name)
+ (let ((result '()))
+ (map-function-constants (fdefinition name)
+ (lambda (c)
+ (when (fboundp c)
+ (push c result)))
+ 2)
+ (xref-result result)))
+
+;;;; Profiling
+
+;; Per-function profiling based on description in
+;; http://www.franz.com/support/documentation/8.0/\
+;; doc/runtime-analyzer.htm#data-collection-control-2
+
+(defvar *profiled-functions* ())
+(defvar *profile-depth* 0)
+
+(defmacro with-redirected-y-or-n-p (&body body)
+ ;; If the profiler is restarted when the data from the previous
+ ;; session is not reported yet, the user is warned via Y-OR-N-P.
+ ;; As the CL:Y-OR-N-P question is (for some reason) not directly
+ ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
+ ;; overruled.
+ `(let* ((pkg (find-package :common-lisp))
+ (saved-pdl (excl::package-definition-lock pkg))
+ (saved-ynp (symbol-function 'cl:y-or-n-p)))
+ (setf (excl::package-definition-lock pkg) nil
+ (symbol-function 'cl:y-or-n-p)
+ (symbol-function (read-from-string "swank:y-or-n-p-in-emacs")))
+ (unwind-protect
+ (progn ,@body)
+ (setf (symbol-function 'cl:y-or-n-p) saved-ynp
+ (excl::package-definition-lock pkg) saved-pdl))))
+
+(defun start-acl-profiler ()
+ (with-redirected-y-or-n-p
+ (prof:start-profiler :type :time :count t
+ :start-sampling-p nil :verbose nil)))
+(defun acl-profiler-active-p ()
+ (not (eq (prof:profiler-status :verbose nil) :inactive)))
+
+(defun stop-acl-profiler ()
+ (prof:stop-profiler :verbose nil))
+
+(excl:def-fwrapper profile-fwrapper (&rest args)
+ ;; Ensures sampling is done during the execution of the function,
+ ;; taking into account recursion.
+ (declare (ignore args))
+ (cond ((zerop *profile-depth*)
+ (let ((*profile-depth* (1+ *profile-depth*)))
+ (prof:start-sampling)
+ (unwind-protect (excl:call-next-fwrapper)
+ (prof:stop-sampling))))
+ (t
+ (excl:call-next-fwrapper))))
+
+(defimplementation profile (fname)
+ (unless (acl-profiler-active-p)
+ (start-acl-profiler))
+ (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
+ (push fname *profiled-functions*))
+
+(defimplementation profiled-functions ()
+ *profiled-functions*)
+
+(defimplementation unprofile (fname)
+ (excl:funwrap fname 'profile-fwrapper)
+ (setq *profiled-functions* (remove fname *profiled-functions*)))
+
+(defimplementation profile-report ()
+ (prof:show-flat-profile :verbose nil)
+ (when *profiled-functions*
+ (start-acl-profiler)))
+
+(defimplementation profile-reset ()
+ (when (acl-profiler-active-p)
+ (stop-acl-profiler)
+ (start-acl-profiler))
+ "Reset profiling counters.")
+
+;;;; Inspecting
+
+(excl:without-redefinition-warnings
+(defmethod emacs-inspect ((o t))
+ (allegro-inspect o)))
+
+(defmethod emacs-inspect ((o function))
+ (allegro-inspect o))
+
+(defmethod emacs-inspect ((o standard-object))
+ (allegro-inspect o))
+
+(defun allegro-inspect (o)
+ (loop for (d dd) on (inspect::inspect-ctl o)
+ append (frob-allegro-field-def o d)
+ until (eq d dd)))
+
+(defun frob-allegro-field-def (object def)
+ (with-struct (inspect::field-def- name type access) def
+ (ecase type
+ ((:unsigned-word :unsigned-byte :unsigned-natural
+ :unsigned-long :unsigned-half-long
+ :unsigned-3byte :unsigned-long32)
+ (label-value-line name (inspect::component-ref-v object access type)))
+ ((:lisp :value :func)
+ (label-value-line name (inspect::component-ref object access)))
+ (:indirect
+ (destructuring-bind (prefix count ref set) access
+ (declare (ignore set prefix))
+ (loop for i below (funcall count object)
+ append (label-value-line (format nil "~A-~D" name i)
+ (funcall ref object i))))))))
+
+;;;; Multithreading
+
+(defimplementation initialize-multiprocessing (continuation)
+ (mp:start-scheduler)
+ (funcall continuation))
+
+(defimplementation spawn (fn &key name)
+ (mp:process-run-function name fn))
+
+(defvar *id-lock* (mp:make-process-lock :name "id lock"))
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (mp:with-process-lock (*id-lock*)
+ (or (getf (mp:process-property-list thread) 'id)
+ (setf (getf (mp:process-property-list thread) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (find id mp:*all-processes*
+ :key (lambda (p) (getf (mp:process-property-list p) 'id))))
+
+(defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+(defimplementation thread-status (thread)
+ (princ-to-string (mp:process-whostate thread)))
+
+(defimplementation thread-attributes (thread)
+ (list :priority (mp:process-priority thread)
+ :times-resumed (mp:process-times-resumed thread)))
+
+(defimplementation make-lock (&key name)
+ (mp:make-process-lock :name name))
+
+(defimplementation call-with-lock-held (lock function)
+ (mp:with-process-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ mp:*current-process*)
+
+(defimplementation all-threads ()
+ (copy-list mp:*all-processes*))
+
+(defimplementation interrupt-thread (thread fn)
+ (mp:process-interrupt thread fn))
+
+(defimplementation kill-thread (thread)
+ (mp:process-kill thread))
+
+(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
+
+(defstruct (mailbox (:conc-name mailbox.))
+ (lock (mp:make-process-lock :name "process mailbox"))
+ (queue '() :type list)
+ (gate (mp:make-gate nil)))
+
+(defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-process-lock (*mailbox-lock*)
+ (or (getf (mp:process-property-list thread) 'mailbox)
+ (setf (getf (mp:process-property-list thread) 'mailbox)
+ (make-mailbox)))))
+
+(defimplementation send (thread message)
+ (let* ((mbox (mailbox thread)))
+ (mp:with-process-lock ((mailbox.lock mbox))
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (mp:open-gate (mailbox.gate mbox)))))
+
+(defimplementation receive-if (test &optional timeout)
+ (let ((mbox (mailbox mp:*current-process*)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (mp:with-process-lock ((mailbox.lock mbox))
+ (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)))
+ (mp:close-gate (mailbox.gate mbox))))
+ (when (eq timeout t) (return (values nil t)))
+ (mp:process-wait-with-timeout "receive-if" 0.5
+ #'mp:gate-open-p (mailbox.gate mbox)))))
+
+(let ((alist '())
+ (lock (mp:make-process-lock :name "register-thread")))
+
+ (defimplementation register-thread (name thread)
+ (declare (type symbol name))
+ (mp:with-process-lock (lock)
+ (etypecase thread
+ (null
+ (setf alist (delete name alist :key #'car)))
+ (mp:process
+ (let ((probe (assoc name alist)))
+ (cond (probe (setf (cdr probe) thread))
+ (t (setf alist (acons name thread alist))))))))
+ nil)
+
+ (defimplementation find-registered (name)
+ (mp:with-process-lock (lock)
+ (cdr (assoc name alist)))))
+
+(defimplementation set-default-initial-binding (var form)
+ (push (cons var form)
+ #+(version>= 9 0)
+ excl:*required-thread-bindings*
+ #-(version>= 9 0)
+ excl::required-thread-bindings))
+
+(defimplementation quit-lisp ()
+ (excl:exit 0 :quiet t))
+
+
+;;Trace implementations
+;;In Allegro 7.0, we have:
+;; (trace <name>)
+;; (trace ((method <name> <qualifier>? (<specializer>+))))
+;; (trace ((labels <name> <label-name>)))
+;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
+;; <name> can be a normal name or a (setf name)
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ (:defgeneric (toggle-trace-generic-function-methods (second spec)))
+ ((setf :defmethod :labels :flet)
+ (toggle-trace-aux (process-fspec-for-allegro spec)))
+ (:call
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux callee
+ :inside (list (process-fspec-for-allegro caller)))))))
+
+(defun tracedp (fspec)
+ (member fspec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (fspec &rest args)
+ (cond ((tracedp fspec)
+ (eval `(untrace ,fspec))
+ (format nil "~S is now untraced." fspec))
+ (t
+ (eval `(trace (,fspec ,@args)))
+ (format nil "~S is now traced." fspec))))
+
+(defun toggle-trace-generic-function-methods (name)
+ (let ((methods (mop:generic-function-methods (fdefinition name))))
+ (cond ((tracedp name)
+ (eval `(untrace ,name))
+ (dolist (method methods (format nil "~S is now untraced." name))
+ (excl:funtrace (mop:method-function method))))
+ (t
+ (eval `(trace (,name)))
+ (dolist (method methods (format nil "~S is now traced." name))
+ (excl:ftrace (mop:method-function method)))))))
+
+(defun process-fspec-for-allegro (fspec)
+ (cond ((consp fspec)
+ (ecase (first fspec)
+ ((setf) fspec)
+ ((:defun :defgeneric) (second fspec))
+ ((:defmethod) `(method ,@(rest fspec)))
+ ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
+ ,(third fspec)))
+ ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
+ ,(third fspec)))))
+ (t
+ fspec)))
+
+
+;;;; Weak hashtables
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-keys t args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ (apply #'make-hash-table :values :weak args))
+
+(defimplementation hash-table-weakness (hashtable)
+ (cond ((excl:hash-table-weak-keys hashtable) :key)
+ ((eq (excl:hash-table-values hashtable) :weak) :value)))
+
+
+
+;;;; Character names
+
+(defimplementation character-completion-set (prefix matchp)
+ (loop for name being the hash-keys of excl::*name-to-char-table*
+ when (funcall matchp prefix name)
+ collect (string-capitalize name)))
+
+
+;;;; wrap interface implementation
+
+(defimplementation wrap (spec indicator &key before after replace)
+ (let ((allegro-spec (process-fspec-for-allegro spec)))
+ (excl:fwrap allegro-spec
+ indicator
+ (excl:def-fwrapper allegro-wrapper (&rest args)
+ (let (retlist completed)
+ (unwind-protect
+ (progn
+ (when before
+ (funcall before args))
+ (setq retlist (multiple-value-list
+ (if replace
+ (funcall replace args)
+ (excl:call-next-fwrapper))))
+ (setq completed t)
+ (values-list retlist))
+ (when after
+ (funcall after (if completed
+ retlist
+ :exited-non-locally)))))))
+ allegro-spec))
+
+(defimplementation unwrap (spec indicator)
+ (let ((allegro-spec (process-fspec-for-allegro spec)))
+ (excl:funwrap allegro-spec indicator)
+ allegro-spec))
+
+(defimplementation wrapped-p (spec indicator)
+ (getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator))
diff --git a/vim/bundle/slimv/slime/swank/backend.lisp b/vim/bundle/slimv/slime/swank/backend.lisp
new file mode 100644
index 0000000..81023df
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/backend.lisp
@@ -0,0 +1,1536 @@
+;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*-
+;;;
+;;; slime-backend.lisp --- SLIME backend interface.
+;;;
+;;; Created by James Bielman in 2003. Released into the public domain.
+;;;
+;;;; Frontmatter
+;;;
+;;; This file defines the functions that must be implemented
+;;; separately for each Lisp. Each is declared as a generic function
+;;; for which swank-<implementation>.lisp provides methods.
+
+(in-package swank/backend)
+
+
+;;;; Metacode
+
+(defparameter *debug-swank-backend* nil
+ "If this is true, backends should not catch errors but enter the
+debugger where appropriate. Also, they should not perform backtrace
+magic but really show every frame including SWANK related ones.")
+
+(defparameter *interface-functions* '()
+ "The names of all interface functions.")
+
+(defparameter *unimplemented-interfaces* '()
+ "List of interface functions that are not implemented.
+DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.")
+
+(defvar *log-output* nil) ; should be nil for image dumpers
+
+(defmacro definterface (name args documentation &rest default-body)
+ "Define an interface function for the backend to implement.
+A function is defined with NAME, ARGS, and DOCUMENTATION. This
+function first looks for a function to call in NAME's property list
+that is indicated by 'IMPLEMENTATION; failing that, it looks for a
+function indicated by 'DEFAULT. If neither is present, an error is
+signaled.
+
+If a DEFAULT-BODY is supplied, then a function with the same body and
+ARGS will be added to NAME's property list as the property indicated
+by 'DEFAULT.
+
+Backends implement these functions using DEFIMPLEMENTATION."
+ (check-type documentation string "a documentation string")
+ (assert (every #'symbolp args) ()
+ "Complex lambda-list not supported: ~S ~S" name args)
+ (labels ((gen-default-impl ()
+ `(setf (get ',name 'default) (lambda ,args ,@default-body)))
+ (args-as-list (args)
+ (destructuring-bind (req opt key rest) (parse-lambda-list args)
+ `(,@req ,@opt
+ ,@(loop for k in key append `(,(kw k) ,k))
+ ,@(or rest '(())))))
+ (parse-lambda-list (args)
+ (parse args '(&optional &key &rest)
+ (make-array 4 :initial-element nil)))
+ (parse (args keywords vars)
+ (cond ((null args)
+ (reverse (map 'list #'reverse vars)))
+ ((member (car args) keywords)
+ (parse (cdr args) (cdr (member (car args) keywords)) vars))
+ (t (push (car args) (aref vars (length keywords)))
+ (parse (cdr args) keywords vars))))
+ (kw (s) (intern (string s) :keyword)))
+ `(progn
+ (defun ,name ,args
+ ,documentation
+ (let ((f (or (get ',name 'implementation)
+ (get ',name 'default))))
+ (cond (f (apply f ,@(args-as-list args)))
+ (t (error "~S not implemented" ',name)))))
+ (pushnew ',name *interface-functions*)
+ ,(if (null default-body)
+ `(pushnew ',name *unimplemented-interfaces*)
+ (gen-default-impl))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (export ',name :swank/backend))
+ ',name)))
+
+(defmacro defimplementation (name args &body body)
+ (assert (every #'symbolp args) ()
+ "Complex lambda-list not supported: ~S ~S" name args)
+ `(progn
+ (setf (get ',name 'implementation)
+ ;; For implicit BLOCK. FLET because of interplay w/ decls.
+ (flet ((,name ,args ,@body)) #',name))
+ (if (member ',name *interface-functions*)
+ (setq *unimplemented-interfaces*
+ (remove ',name *unimplemented-interfaces*))
+ (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
+ ',name))
+
+(defun warn-unimplemented-interfaces ()
+ "Warn the user about unimplemented backend features.
+The portable code calls this function at startup."
+ (let ((*print-pretty* t))
+ (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>"
+ (list (sort (copy-list *unimplemented-interfaces*) #'string<)))))
+
+(defun import-to-swank-mop (symbol-list)
+ (dolist (sym symbol-list)
+ (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop)))
+ (when swank-mop-sym
+ (unintern swank-mop-sym :swank-mop))
+ (import sym :swank-mop)
+ (export sym :swank-mop))))
+
+(defun import-swank-mop-symbols (package except)
+ "Import the mop symbols from PACKAGE to SWANK-MOP.
+EXCEPT is a list of symbol names which should be ignored."
+ (do-symbols (s :swank-mop)
+ (unless (member s except :test #'string=)
+ (let ((real-symbol (find-symbol (string s) package)))
+ (assert real-symbol () "Symbol ~A not found in package ~A" s package)
+ (unintern s :swank-mop)
+ (import real-symbol :swank-mop)
+ (export real-symbol :swank-mop)))))
+
+(definterface gray-package-name ()
+ "Return a package-name that contains the Gray stream symbols.
+This will be used like so:
+ (defpackage foo
+ (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)")
+
+
+;;;; Utilities
+
+(defmacro with-struct ((conc-name &rest names) obj &body body)
+ "Like with-slots but works only for structs."
+ (check-type conc-name symbol)
+ (flet ((reader (slot)
+ (intern (concatenate 'string
+ (symbol-name conc-name)
+ (symbol-name slot))
+ (symbol-package conc-name))))
+ (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)))))
+
+(defmacro when-let ((var value) &body body)
+ `(let ((,var ,value))
+ (when ,var ,@body)))
+
+(defun boolean-to-feature-expression (value)
+ "Converts a boolean VALUE to a form suitable for testing with #+."
+ (if value
+ '(:and)
+ '(:or)))
+
+(defun with-symbol (name package)
+ "Check if a symbol with a given NAME exists in PACKAGE and returns a
+form suitable for testing with #+."
+ (boolean-to-feature-expression
+ (and (find-package package)
+ (find-symbol (string name) package))))
+
+(defun choose-symbol (package name alt-package alt-name)
+ "If symbol package:name exists return that symbol, otherwise alt-package:alt-name.
+ Suitable for use with #."
+ (or (and (find-package package)
+ (find-symbol (string name) package))
+ (find-symbol (string alt-name) alt-package)))
+
+
+;;;; UFT8
+
+(deftype octet () '(unsigned-byte 8))
+(deftype octets () '(simple-array octet (*)))
+
+;; Helper function. Decode the next N bytes starting from INDEX.
+;; Return the decoded char and the new index.
+(defun utf8-decode-aux (buffer index limit byte0 n)
+ (declare (type octets buffer) (fixnum index limit byte0 n))
+ (if (< (- limit index) n)
+ (values nil index)
+ (do ((i 0 (1+ i))
+ (code byte0 (let ((byte (aref buffer (+ index i))))
+ (cond ((= (ldb (byte 2 6) byte) #b10)
+ (+ (ash code 6) (ldb (byte 6 0) byte)))
+ (t
+ (error "Invalid encoding"))))))
+ ((= i n)
+ (values (cond ((<= code #xff) (code-char code))
+ ((<= #xd800 code #xdfff)
+ (error "Invalid Unicode code point: #x~x" code))
+ ((and (< code char-code-limit)
+ (code-char code)))
+ (t
+ (error
+ "Can't represent code point: #x~x ~
+ (char-code-limit is #x~x)"
+ code char-code-limit)))
+ (+ index n))))))
+
+;; Decode one character in BUFFER starting at INDEX.
+;; Return 2 values: the character and the new index.
+;; If there aren't enough bytes between INDEX and LIMIT return nil.
+(defun utf8-decode (buffer index limit)
+ (declare (type octets buffer) (fixnum index limit))
+ (if (= index limit)
+ (values nil index)
+ (let ((b (aref buffer index)))
+ (if (<= b #x7f)
+ (values (code-char b) (1+ index))
+ (macrolet ((try (marker else)
+ (let* ((l (integer-length marker))
+ (n (- l 2)))
+ `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker)
+ (utf8-decode-aux buffer (1+ index) limit
+ (ldb (byte ,(- 8 l) 0) b)
+ ,n)
+ ,else))))
+ (try #b110
+ (try #b1110
+ (try #b11110
+ (try #b111110
+ (try #b1111110
+ (error "Invalid encoding")))))))))))
+
+;; Decode characters from BUFFER and write them to STRING.
+;; Return 2 values: LASTINDEX and LASTSTART where
+;; LASTINDEX is the last index in BUFFER that was not decoded
+;; and LASTSTART is the last index in STRING not written.
+(defun utf8-decode-into (buffer index limit string start end)
+ (declare (string string) (fixnum index limit start end) (type octets buffer))
+ (loop
+ (cond ((= start end)
+ (return (values index start)))
+ (t
+ (multiple-value-bind (c i) (utf8-decode buffer index limit)
+ (cond (c
+ (setf (aref string start) c)
+ (setq index i)
+ (setq start (1+ start)))
+ (t
+ (return (values index start)))))))))
+
+(defun default-utf8-to-string (octets)
+ (let* ((limit (length octets))
+ (str (make-string limit)))
+ (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit)
+ (if (= i limit)
+ (if (= limit s)
+ str
+ (adjust-array str s))
+ (loop
+ (let ((end (+ (length str) (- limit i))))
+ (setq str (adjust-array str end))
+ (multiple-value-bind (i2 s2)
+ (utf8-decode-into octets i limit str s end)
+ (cond ((= i2 limit)
+ (return (adjust-array str s2)))
+ (t
+ (setq i i2)
+ (setq s s2))))))))))
+
+(defmacro utf8-encode-aux (code buffer start end n)
+ `(cond ((< (- ,end ,start) ,n)
+ ,start)
+ (t
+ (setf (aref ,buffer ,start)
+ (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code)
+ (byte ,(- 7 n) 0)
+ ,(dpb 0 (byte 1 (- 7 n)) #xff)))
+ ,@(loop for i from 0 upto (- n 2) collect
+ `(setf (aref ,buffer (+ ,start ,(- n 1 i)))
+ (dpb (ldb (byte 6 ,(* 6 i)) ,code)
+ (byte 6 0)
+ #b10111111)))
+ (+ ,start ,n))))
+
+(defun %utf8-encode (code buffer start end)
+ (declare (type (unsigned-byte 31) code) (type octets buffer)
+ (type (and fixnum unsigned-byte) start end))
+ (cond ((<= code #x7f)
+ (cond ((< start end)
+ (setf (aref buffer start) code)
+ (1+ start))
+ (t start)))
+ ((<= code #x7ff) (utf8-encode-aux code buffer start end 2))
+ ((<= #xd800 code #xdfff)
+ (error "Invalid Unicode code point (surrogate): #x~x" code))
+ ((<= code #xffff) (utf8-encode-aux code buffer start end 3))
+ ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4))
+ ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5))
+ (t (utf8-encode-aux code buffer start end 6))))
+
+(defun utf8-encode (char buffer start end)
+ (declare (type character char) (type octets buffer)
+ (type (and fixnum unsigned-byte) start end))
+ (%utf8-encode (char-code char) buffer start end))
+
+(defun utf8-encode-into (string start end buffer index limit)
+ (declare (string string) (type octets buffer) (fixnum start end index limit))
+ (loop
+ (cond ((= start end)
+ (return (values start index)))
+ ((= index limit)
+ (return (values start index)))
+ (t
+ (let ((i2 (utf8-encode (char string start) buffer index limit)))
+ (cond ((= i2 index)
+ (return (values start index)))
+ (t
+ (setq index i2)
+ (incf start))))))))
+
+(defun default-string-to-utf8 (string)
+ (let* ((len (length string))
+ (b (make-array len :element-type 'octet)))
+ (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len)
+ (if (= s len)
+ b
+ (loop
+ (let ((limit (+ (length b) (- len s))))
+ (setq b (coerce (adjust-array b limit) 'octets))
+ (multiple-value-bind (s2 i2)
+ (utf8-encode-into string s len b i limit)
+ (cond ((= s2 len)
+ (return (coerce (adjust-array b i2) 'octets)))
+ (t
+ (setq i i2)
+ (setq s s2))))))))))
+
+(definterface string-to-utf8 (string)
+ "Convert the string STRING to a (simple-array (unsigned-byte 8))"
+ (default-string-to-utf8 string))
+
+(definterface utf8-to-string (octets)
+ "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string."
+ (default-utf8-to-string octets))
+
+
+;;;; TCP server
+
+(definterface create-socket (host port &key backlog)
+ "Create a listening TCP socket on interface HOST and port PORT.
+BACKLOG queue length for incoming connections.")
+
+(definterface local-port (socket)
+ "Return the local port number of SOCKET.")
+
+(definterface close-socket (socket)
+ "Close the socket SOCKET.")
+
+(definterface accept-connection (socket &key external-format
+ buffering timeout)
+ "Accept a client connection on the listening socket SOCKET.
+Return a stream for the new connection.
+If EXTERNAL-FORMAT is nil return a binary stream
+otherwise create a character stream.
+BUFFERING can be one of:
+ nil ... no buffering
+ t ... enable buffering
+ :line ... enable buffering with automatic flushing on eol.")
+
+(definterface add-sigio-handler (socket fn)
+ "Call FN whenever SOCKET is readable.")
+
+(definterface remove-sigio-handlers (socket)
+ "Remove all sigio handlers for SOCKET.")
+
+(definterface add-fd-handler (socket fn)
+ "Call FN when Lisp is waiting for input and SOCKET is readable.")
+
+(definterface remove-fd-handlers (socket)
+ "Remove all fd-handlers for SOCKET.")
+
+(definterface preferred-communication-style ()
+ "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
+ nil)
+
+(definterface set-stream-timeout (stream timeout)
+ "Set the 'stream 'timeout. The timeout is either the real number
+ specifying the timeout in seconds or 'nil for no timeout."
+ (declare (ignore stream timeout))
+ nil)
+
+;;; Base condition for networking errors.
+(define-condition network-error (simple-error) ())
+
+(definterface emacs-connected ()
+ "Hook called when the first connection from Emacs is established.
+Called from the INIT-FN of the socket server that accepts the
+connection.
+
+This is intended for setting up extra context, e.g. to discover
+that the calling thread is the one that interacts with Emacs."
+ nil)
+
+
+;;;; Unix signals
+
+(defconstant +sigint+ 2)
+
+(definterface getpid ()
+ "Return the (Unix) process ID of this superior Lisp.")
+
+(definterface install-sigint-handler (function)
+ "Call FUNCTION on SIGINT (instead of invoking the debugger).
+Return old signal handler."
+ (declare (ignore function))
+ nil)
+
+(definterface call-with-user-break-handler (handler function)
+ "Install the break handler HANDLER while executing FUNCTION."
+ (let ((old-handler (install-sigint-handler handler)))
+ (unwind-protect (funcall function)
+ (install-sigint-handler old-handler))))
+
+(definterface quit-lisp ()
+ "Exit the current lisp image.")
+
+(definterface lisp-implementation-type-name ()
+ "Return a short name for the Lisp implementation."
+ (lisp-implementation-type))
+
+(definterface lisp-implementation-program ()
+ "Return the argv[0] of the running Lisp process, or NIL."
+ (let ((file (car (command-line-args))))
+ (when (and file (probe-file file))
+ (namestring (truename file)))))
+
+(definterface socket-fd (socket-stream)
+ "Return the file descriptor for SOCKET-STREAM.")
+
+(definterface make-fd-stream (fd external-format)
+ "Create a character stream for the file descriptor FD.")
+
+(definterface dup (fd)
+ "Duplicate a file descriptor.
+If the syscall fails, signal a condition.
+See dup(2).")
+
+(definterface exec-image (image-file args)
+ "Replace the current process with a new process image.
+The new image is created by loading the previously dumped
+core file IMAGE-FILE.
+ARGS is a list of strings passed as arguments to
+the new image.
+This is thin wrapper around exec(3).")
+
+(definterface command-line-args ()
+ "Return a list of strings as passed by the OS."
+ nil)
+
+
+;; pathnames are sooo useless
+
+(definterface filename-to-pathname (filename)
+ "Return a pathname for FILENAME.
+A filename in Emacs may for example contain asterisks which should not
+be translated to wildcards."
+ (parse-namestring filename))
+
+(definterface pathname-to-filename (pathname)
+ "Return the filename for PATHNAME."
+ (namestring pathname))
+
+(definterface default-directory ()
+ "Return the default directory."
+ (directory-namestring (truename *default-pathname-defaults*)))
+
+(definterface set-default-directory (directory)
+ "Set the default directory.
+This is used to resolve filenames without directory component."
+ (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
+ (default-directory))
+
+
+(definterface call-with-syntax-hooks (fn)
+ "Call FN with hooks to handle special syntax."
+ (funcall fn))
+
+(definterface default-readtable-alist ()
+ "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
+ '())
+
+
+;;;; Packages
+
+(definterface package-local-nicknames (package)
+ "Returns an alist of (local-nickname . actual-package) describing the
+nicknames local to the designated package."
+ (declare (ignore package))
+ nil)
+
+(definterface find-locally-nicknamed-package (name base-package)
+ "Return the package whose local nickname in BASE-PACKAGE matches NAME.
+Return NIL if local nicknames are not implemented or if there is no
+such package."
+ (cdr (assoc name (package-local-nicknames base-package) :test #'string-equal)))
+
+
+;;;; Compilation
+
+(definterface call-with-compilation-hooks (func)
+ "Call FUNC with hooks to record compiler conditions.")
+
+(defmacro with-compilation-hooks ((&rest ignore) &body body)
+ "Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
+ (declare (ignore ignore))
+ `(call-with-compilation-hooks (lambda () (progn ,@body))))
+
+(definterface swank-compile-string (string &key buffer position filename
+ policy)
+ "Compile source from STRING.
+During compilation, compiler conditions must be trapped and
+resignalled as COMPILER-CONDITIONs.
+
+If supplied, BUFFER and POSITION specify the source location in Emacs.
+
+Additionally, if POSITION is supplied, it must be added to source
+positions reported in compiler conditions.
+
+If FILENAME is specified it may be used by certain implementations to
+rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
+source information.
+
+If POLICY is supplied, and non-NIL, it may be used by certain
+implementations to compile with optimization qualities of its
+value.
+
+Should return T on successful compilation, NIL otherwise.
+")
+
+(definterface swank-compile-file (input-file output-file load-p
+ external-format
+ &key policy)
+ "Compile INPUT-FILE signalling COMPILE-CONDITIONs.
+If LOAD-P is true, load the file after compilation.
+EXTERNAL-FORMAT is a value returned by find-external-format or
+:default.
+
+If POLICY is supplied, and non-NIL, it may be used by certain
+implementations to compile with optimization qualities of its
+value.
+
+Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
+like `compile-file'")
+
+(deftype severity ()
+ '(member :error :read-error :warning :style-warning :note :redefinition))
+
+;; Base condition type for compiler errors, warnings and notes.
+(define-condition compiler-condition (condition)
+ ((original-condition
+ ;; The original condition thrown by the compiler if appropriate.
+ ;; May be NIL if a compiler does not report using conditions.
+ :type (or null condition)
+ :initarg :original-condition
+ :accessor original-condition)
+
+ (severity :type severity
+ :initarg :severity
+ :accessor severity)
+
+ (message :initarg :message
+ :accessor message)
+
+ ;; Macro expansion history etc. which may be helpful in some cases
+ ;; but is often very verbose.
+ (source-context :initarg :source-context
+ :type (or null string)
+ :initform nil
+ :accessor source-context)
+
+ (references :initarg :references
+ :initform nil
+ :accessor references)
+
+ (location :initarg :location
+ :accessor location)))
+
+(definterface find-external-format (coding-system)
+ "Return a \"external file format designator\" for CODING-SYSTEM.
+CODING-SYSTEM is Emacs-style coding system name (a string),
+e.g. \"latin-1-unix\"."
+ (if (equal coding-system "iso-latin-1-unix")
+ :default
+ nil))
+
+(definterface guess-external-format (pathname)
+ "Detect the external format for the file with name pathname.
+Return nil if the file contains no special markers."
+ ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
+ (with-open-file (s pathname :if-does-not-exist nil
+ :external-format (or (find-external-format "latin-1-unix")
+ :default))
+ (if s
+ (or (let* ((line (read-line s nil))
+ (p (search "-*-" line)))
+ (when p
+ (let* ((start (+ p (length "-*-")))
+ (end (search "-*-" line :start2 start)))
+ (when end
+ (%search-coding line start end)))))
+ (let* ((len (file-length s))
+ (buf (make-string (min len 3000))))
+ (file-position s (- len (length buf)))
+ (read-sequence buf s)
+ (let ((start (search "Local Variables:" buf :from-end t))
+ (end (search "End:" buf :from-end t)))
+ (and start end (< start end)
+ (%search-coding buf start end))))))))
+
+(defun %search-coding (str start end)
+ (let ((p (search "coding:" str :start2 start :end2 end)))
+ (when p
+ (incf p (length "coding:"))
+ (loop while (and (< p end)
+ (member (aref str p) '(#\space #\tab)))
+ do (incf p))
+ (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
+ str :start p)))
+ (find-external-format (subseq str p end))))))
+
+
+;;;; Streams
+
+(definterface make-output-stream (write-string)
+ "Return a new character output stream.
+The stream calls WRITE-STRING when output is ready.")
+
+(definterface make-input-stream (read-string)
+ "Return a new character input stream.
+The stream calls READ-STRING when input is needed.")
+
+
+;;;; Documentation
+
+(definterface arglist (name)
+ "Return the lambda list for the symbol NAME. NAME can also be
+a lisp function object, on lisps which support this.
+
+The result can be a list or the :not-available keyword if the
+arglist cannot be determined."
+ (declare (ignore name))
+ :not-available)
+
+(defgeneric declaration-arglist (decl-identifier)
+ (:documentation
+ "Return the argument list of the declaration specifier belonging to the
+declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
+the keyword :NOT-AVAILABLE is returned.
+
+The different SWANK backends can specialize this generic function to
+include implementation-dependend declaration specifiers, or to provide
+additional information on the specifiers defined in ANSI Common Lisp.")
+ (:method (decl-identifier)
+ (case decl-identifier
+ (dynamic-extent '(&rest variables))
+ (ignore '(&rest variables))
+ (ignorable '(&rest variables))
+ (special '(&rest variables))
+ (inline '(&rest function-names))
+ (notinline '(&rest function-names))
+ (declaration '(&rest names))
+ (optimize '(&any compilation-speed debug safety space speed))
+ (type '(type-specifier &rest args))
+ (ftype '(type-specifier &rest function-names))
+ (otherwise
+ (flet ((typespec-p (symbol)
+ (member :type (describe-symbol-for-emacs symbol))))
+ (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
+ '(&rest variables))
+ ((and (listp decl-identifier)
+ (typespec-p (first decl-identifier)))
+ '(&rest variables))
+ (t :not-available)))))))
+
+(defgeneric type-specifier-arglist (typespec-operator)
+ (:documentation
+ "Return the argument list of the type specifier belonging to
+TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
+:NOT-AVAILABLE is returned.
+
+The different SWANK backends can specialize this generic function to
+include implementation-dependend declaration specifiers, or to provide
+additional information on the specifiers defined in ANSI Common Lisp.")
+ (:method (typespec-operator)
+ (declare (special *type-specifier-arglists*)) ; defined at end of file.
+ (typecase typespec-operator
+ (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
+ :not-available))
+ (t :not-available))))
+
+(definterface type-specifier-p (symbol)
+ "Determine if SYMBOL is a type-specifier."
+ (or (documentation symbol 'type)
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+(definterface function-name (function)
+ "Return the name of the function object FUNCTION.
+
+The result is either a symbol, a list, or NIL if no function name is
+available."
+ (declare (ignore function))
+ nil)
+
+(definterface valid-function-name-p (form)
+ "Is FORM syntactically valid to name a function?
+ If true, FBOUNDP should not signal a type-error for FORM."
+ (flet ((length=2 (list)
+ (and (not (null (cdr list))) (null (cddr list)))))
+ (or (symbolp form)
+ (and (consp form) (length=2 form)
+ (eq (first form) 'setf) (symbolp (second form))))))
+
+(definterface macroexpand-all (form &optional env)
+ "Recursively expand all macros in FORM.
+Return the resulting form.")
+
+(definterface compiler-macroexpand-1 (form &optional env)
+ "Call the compiler-macro for form.
+If FORM is a function call for which a compiler-macro has been
+defined, invoke the expander function using *macroexpand-hook* and
+return the results and T. Otherwise, return the original form and
+NIL."
+ (let ((fun (and (consp form)
+ (valid-function-name-p (car form))
+ (compiler-macro-function (car form) env))))
+ (if fun
+ (let ((result (funcall *macroexpand-hook* fun form env)))
+ (values result (not (eq result form))))
+ (values form nil))))
+
+(definterface compiler-macroexpand (form &optional env)
+ "Repetitively call `compiler-macroexpand-1'."
+ (labels ((frob (form expanded)
+ (multiple-value-bind (new-form newly-expanded)
+ (compiler-macroexpand-1 form env)
+ (if newly-expanded
+ (frob new-form t)
+ (values new-form expanded)))))
+ (frob form env)))
+
+(defmacro with-collected-macro-forms
+ ((forms &optional result) instrumented-form &body body)
+ "Collect macro forms by locally binding *MACROEXPAND-HOOK*.
+
+Evaluates INSTRUMENTED-FORM and collects any forms which undergo
+macro-expansion into a list. Then evaluates BODY with FORMS bound to
+the list of forms, and RESULT (optionally) bound to the value of
+INSTRUMENTED-FORM."
+ (assert (and (symbolp forms) (not (null forms))))
+ (assert (symbolp result))
+ (let ((result-symbol (or result (gensym))))
+ `(call-with-collected-macro-forms
+ (lambda (,forms ,result-symbol)
+ (declare (ignore ,@(and (not result)
+ `(,result-symbol))))
+ ,@body)
+ (lambda () ,instrumented-form))))
+
+(defun call-with-collected-macro-forms (body-fn instrumented-fn)
+ (let ((return-value nil)
+ (collected-forms '()))
+ (let* ((real-macroexpand-hook *macroexpand-hook*)
+ (*macroexpand-hook*
+ (lambda (macro-function form environment)
+ (let ((result (funcall real-macroexpand-hook
+ macro-function form environment)))
+ (unless (eq result form)
+ (push form collected-forms))
+ result))))
+ (setf return-value (funcall instrumented-fn)))
+ (funcall body-fn collected-forms return-value)))
+
+(definterface collect-macro-forms (form &optional env)
+ "Collect subforms of FORM which undergo (compiler-)macro expansion.
+Returns two values: a list of macro forms and a list of compiler macro
+forms."
+ (with-collected-macro-forms (macro-forms expansion)
+ (ignore-errors (macroexpand-all form env))
+ (with-collected-macro-forms (compiler-macro-forms)
+ (handler-bind ((warning #'muffle-warning))
+ (ignore-errors
+ (compile nil `(lambda () ,expansion))))
+ (values macro-forms compiler-macro-forms))))
+
+(definterface format-string-expand (control-string)
+ "Expand the format string CONTROL-STRING."
+ (macroexpand `(formatter ,control-string)))
+
+(definterface describe-symbol-for-emacs (symbol)
+ "Return a property list describing SYMBOL.
+
+The property list has an entry for each interesting aspect of the
+symbol. The recognised keys are:
+
+ :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
+ :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
+
+The value of each property is the corresponding documentation string,
+or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys
+not listed here (but slime-print-apropos in Emacs must know about
+them).
+
+Properties should be included if and only if they are applicable to
+the symbol. For example, only (and all) fbound symbols should include
+the :FUNCTION property.
+
+Example:
+\(describe-symbol-for-emacs 'vector)
+ => (:CLASS :NOT-DOCUMENTED
+ :TYPE :NOT-DOCUMENTED
+ :FUNCTION \"Constructs a simple-vector from the given objects.\")")
+
+(definterface describe-definition (name type)
+ "Describe the definition NAME of TYPE.
+TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
+
+Return a documentation string, or NIL if none is available.")
+
+
+;;;; Debugging
+
+(definterface install-debugger-globally (function)
+ "Install FUNCTION as the debugger for all threads/processes. This
+usually involves setting *DEBUGGER-HOOK* and, if the implementation
+permits, hooking into BREAK as well."
+ (setq *debugger-hook* function))
+
+(definterface call-with-debugging-environment (debugger-loop-fn)
+ "Call DEBUGGER-LOOP-FN in a suitable debugging environment.
+
+This function is called recursively at each debug level to invoke the
+debugger loop. The purpose is to setup any necessary environment for
+other debugger callbacks that will be called within the debugger loop.
+
+For example, this is a reasonable place to compute a backtrace, switch
+to safe reader/printer settings, and so on.")
+
+(definterface call-with-debugger-hook (hook fun)
+ "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
+
+HOOK should be called for both BREAK and INVOKE-DEBUGGER."
+ (let ((*debugger-hook* hook))
+ (funcall fun)))
+
+(define-condition sldb-condition (condition)
+ ((original-condition
+ :initarg :original-condition
+ :accessor original-condition))
+ (:report (lambda (condition stream)
+ (format stream "Condition in debugger code~@[: ~A~]"
+ (original-condition condition))))
+ (:documentation
+ "Wrapper for conditions that should not be debugged.
+
+When a condition arises from the internals of the debugger, it is not
+desirable to debug it -- we'd risk entering an endless loop trying to
+debug the debugger! Instead, such conditions can be reported to the
+user without (re)entering the debugger by wrapping them as
+`sldb-condition's."))
+
+;;; The following functions in this section are supposed to be called
+;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
+
+(definterface compute-backtrace (start end)
+ "Returns a backtrace of the condition currently being debugged,
+that is an ordered list consisting of frames. ``Ordered list''
+means that an integer I can be mapped back to the i-th frame of this
+backtrace.
+
+START and END are zero-based indices constraining the number of frames
+returned. Frame zero is defined as the frame which invoked the
+debugger. If END is nil, return the frames from START to the end of
+the stack.")
+
+(definterface print-frame (frame stream)
+ "Print frame to stream.")
+
+(definterface frame-restartable-p (frame)
+ "Is the frame FRAME restartable?.
+Return T if `restart-frame' can safely be called on the frame."
+ (declare (ignore frame))
+ nil)
+
+(definterface frame-source-location (frame-number)
+ "Return the source location for the frame associated to FRAME-NUMBER.")
+
+(definterface frame-catch-tags (frame-number)
+ "Return a list of catch tags for being printed in a debugger stack
+frame."
+ (declare (ignore frame-number))
+ '())
+
+(definterface frame-locals (frame-number)
+ "Return a list of ((&key NAME ID VALUE) ...) where each element of
+the list represents a local variable in the stack frame associated to
+FRAME-NUMBER.
+
+NAME, a symbol; the name of the local variable.
+
+ID, an integer; used as primary key for the local variable, unique
+relatively to the frame under operation.
+
+value, an object; the value of the local variable.")
+
+(definterface frame-var-value (frame-number var-id)
+ "Return the value of the local variable associated to VAR-ID
+relatively to the frame associated to FRAME-NUMBER.")
+
+(definterface disassemble-frame (frame-number)
+ "Disassemble the code for the FRAME-NUMBER.
+The output should be written to standard output.
+FRAME-NUMBER is a non-negative integer.")
+
+(definterface eval-in-frame (form frame-number)
+ "Evaluate a Lisp form in the lexical context of a stack frame
+in the debugger.
+
+FRAME-NUMBER must be a positive integer with 0 indicating the
+frame which invoked the debugger.
+
+The return value is the result of evaulating FORM in the
+appropriate context.")
+
+(definterface frame-package (frame-number)
+ "Return the package corresponding to the frame at FRAME-NUMBER.
+Return nil if the backend can't figure it out."
+ (declare (ignore frame-number))
+ nil)
+
+(definterface frame-call (frame-number)
+ "Return a string representing a call to the entry point of a frame.")
+
+(definterface return-from-frame (frame-number form)
+ "Unwind the stack to the frame FRAME-NUMBER and return the value(s)
+produced by evaluating FORM in the frame context to its caller.
+
+Execute any clean-up code from unwind-protect forms above the frame
+during unwinding.
+
+Return a string describing the error if it's not possible to return
+from the frame.")
+
+(definterface restart-frame (frame-number)
+ "Restart execution of the frame FRAME-NUMBER with the same arguments
+as it was called originally.")
+
+(definterface print-condition (condition stream)
+ "Print a condition for display in SLDB."
+ (princ condition stream))
+
+(definterface condition-extras (condition)
+ "Return a list of extra for the debugger.
+The allowed elements are of the form:
+ (:SHOW-FRAME-SOURCE frame-number)
+ (:REFERENCES &rest refs)
+"
+ (declare (ignore condition))
+ '())
+
+(definterface gdb-initial-commands ()
+ "List of gdb commands supposed to be executed first for the
+ ATTACH-GDB restart."
+ nil)
+
+(definterface activate-stepping (frame-number)
+ "Prepare the frame FRAME-NUMBER for stepping.")
+
+(definterface sldb-break-on-return (frame-number)
+ "Set a breakpoint in the frame FRAME-NUMBER.")
+
+(definterface sldb-break-at-start (symbol)
+ "Set a breakpoint on the beginning of the function for SYMBOL.")
+
+(definterface sldb-stepper-condition-p (condition)
+ "Return true if SLDB was invoked due to a single-stepping condition,
+false otherwise. "
+ (declare (ignore condition))
+ nil)
+
+(definterface sldb-step-into ()
+ "Step into the current single-stepper form.")
+
+(definterface sldb-step-next ()
+ "Step to the next form in the current function.")
+
+(definterface sldb-step-out ()
+ "Stop single-stepping temporarily, but resume it once the current function
+returns.")
+
+
+;;;; Definition finding
+
+(defstruct (:location (:type list) :named
+ (:constructor make-location
+ (buffer position &optional hints)))
+ buffer position
+ ;; Hints is a property list optionally containing:
+ ;; :snippet SOURCE-TEXT
+ ;; This is a snippet of the actual source text at the start of
+ ;; the definition, which could be used in a text search.
+ hints)
+
+(defstruct (:error (:type list) :named (:constructor)) message)
+
+;;; Valid content for BUFFER slot
+(defstruct (:file (:type list) :named (:constructor)) name)
+(defstruct (:buffer (:type list) :named (:constructor)) name)
+(defstruct (:etags-file (:type list) :named (:constructor)) filename)
+
+;;; Valid content for POSITION slot
+(defstruct (:position (:type list) :named (:constructor)) pos)
+(defstruct (:tag (:type list) :named (:constructor)) tag1 tag2)
+
+(defmacro converting-errors-to-error-location (&body body)
+ "Catches errors during BODY and converts them to an error location."
+ (let ((gblock (gensym "CONVERTING-ERRORS+")))
+ `(block ,gblock
+ (handler-bind ((error
+ #'(lambda (e)
+ (if *debug-swank-backend*
+ nil ;decline
+ (return-from ,gblock
+ (make-error-location e))))))
+ ,@body))))
+
+(defun make-error-location (datum &rest args)
+ (cond ((typep datum 'condition)
+ `(:error ,(format nil "Error: ~A" datum)))
+ ((symbolp datum)
+ `(:error ,(format nil "Error: ~A"
+ (apply #'make-condition datum args))))
+ (t
+ (assert (stringp datum))
+ `(:error ,(apply #'format nil datum args)))))
+
+(definterface find-definitions (name)
+ "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
+
+NAME is a \"definition specifier\".
+
+DSPEC is a \"definition specifier\" describing the
+definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
+\(DEFVAR FOO).
+
+LOCATION is the source location for the definition.")
+
+(definterface find-source-location (object)
+ "Returns the source location of OBJECT, or NIL.
+
+That is the source location of the underlying datastructure of
+OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
+respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
+respective DEFSTRUCT definition, and so on."
+ ;; This returns one source location and not a list of locations. It's
+ ;; supposed to return the location of the DEFGENERIC definition on
+ ;; #'SOME-GENERIC-FUNCTION.
+ (declare (ignore object))
+ (make-error-location "FIND-SOURCE-LOCATION is not yet implemented on ~
+ this implementation."))
+
+(definterface buffer-first-change (filename)
+ "Called for effect the first time FILENAME's buffer is modified.
+CMUCL/SBCL use this to cache the unmodified file and use the
+unmodified text to improve the precision of source locations."
+ (declare (ignore filename))
+ nil)
+
+
+
+;;;; XREF
+
+(definterface who-calls (function-name)
+ "Return the call sites of FUNCTION-NAME (a symbol).
+The results is a list ((DSPEC LOCATION) ...)."
+ (declare (ignore function-name))
+ :not-implemented)
+
+(definterface calls-who (function-name)
+ "Return the call sites of FUNCTION-NAME (a symbol).
+The results is a list ((DSPEC LOCATION) ...)."
+ (declare (ignore function-name))
+ :not-implemented)
+
+(definterface who-references (variable-name)
+ "Return the locations where VARIABLE-NAME (a symbol) is referenced.
+See WHO-CALLS for a description of the return value."
+ (declare (ignore variable-name))
+ :not-implemented)
+
+(definterface who-binds (variable-name)
+ "Return the locations where VARIABLE-NAME (a symbol) is bound.
+See WHO-CALLS for a description of the return value."
+ (declare (ignore variable-name))
+ :not-implemented)
+
+(definterface who-sets (variable-name)
+ "Return the locations where VARIABLE-NAME (a symbol) is set.
+See WHO-CALLS for a description of the return value."
+ (declare (ignore variable-name))
+ :not-implemented)
+
+(definterface who-macroexpands (macro-name)
+ "Return the locations where MACRO-NAME (a symbol) is expanded.
+See WHO-CALLS for a description of the return value."
+ (declare (ignore macro-name))
+ :not-implemented)
+
+(definterface who-specializes (class-name)
+ "Return the locations where CLASS-NAME (a symbol) is specialized.
+See WHO-CALLS for a description of the return value."
+ (declare (ignore class-name))
+ :not-implemented)
+
+;;; Simpler variants.
+
+(definterface list-callers (function-name)
+ "List the callers of FUNCTION-NAME.
+This function is like WHO-CALLS except that it is expected to use
+lower-level means. Whereas WHO-CALLS is usually implemented with
+special compiler support, LIST-CALLERS is usually implemented by
+groveling for constants in function objects throughout the heap.
+
+The return value is as for WHO-CALLS.")
+
+(definterface list-callees (function-name)
+ "List the functions called by FUNCTION-NAME.
+See LIST-CALLERS for a description of the return value.")
+
+
+;;;; Profiling
+
+;;; The following functions define a minimal profiling interface.
+
+(definterface profile (fname)
+ "Marks symbol FNAME for profiling.")
+
+(definterface profiled-functions ()
+ "Returns a list of profiled functions.")
+
+(definterface unprofile (fname)
+ "Marks symbol FNAME as not profiled.")
+
+(definterface unprofile-all ()
+ "Marks all currently profiled functions as not profiled."
+ (dolist (f (profiled-functions))
+ (unprofile f)))
+
+(definterface profile-report ()
+ "Prints profile report.")
+
+(definterface profile-reset ()
+ "Resets profile counters.")
+
+(definterface profile-package (package callers-p methods)
+ "Wrap profiling code around all functions in PACKAGE. If a function
+is already profiled, then unprofile and reprofile (useful to notice
+function redefinition.)
+
+If CALLERS-P is T names have counts of the most common calling
+functions recorded.
+
+When called with arguments :METHODS T, profile all methods of all
+generic functions having names in the given package. Generic functions
+themselves, that is, their dispatch functions, are left alone.")
+
+
+;;;; Trace
+
+(definterface toggle-trace (spec)
+ "Toggle tracing of the function(s) given with SPEC.
+SPEC can be:
+ (setf NAME) ; a setf function
+ (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
+ (:defgeneric NAME) ; a generic function with all methods
+ (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE.
+ (:labels TOPLEVEL LOCAL)
+ (:flet TOPLEVEL LOCAL) ")
+
+
+;;;; Inspector
+
+(defgeneric emacs-inspect (object)
+ (:documentation
+ "Explain to Emacs how to inspect OBJECT.
+
+Returns a list specifying how to render the object for inspection.
+
+Every element of the list must be either a string, which will be
+inserted into the buffer as is, or a list of the form:
+
+ (:value object &optional format) - Render an inspectable
+ object. If format is provided it must be a string and will be
+ rendered in place of the value, otherwise use princ-to-string.
+
+ (:newline) - Render a \\n
+
+ (:action label lambda &key (refresh t)) - Render LABEL (a text
+ string) which when clicked will call LAMBDA. If REFRESH is
+ non-NIL the currently inspected object will be re-inspected
+ after calling the lambda.
+"))
+
+(defmethod emacs-inspect ((object t))
+ "Generic method for inspecting any kind of object.
+
+Since we don't know how to deal with OBJECT we simply dump the
+output of CL:DESCRIBE."
+ `("Type: " (:value ,(type-of object)) (:newline)
+ "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
+ (:newline) (:newline)
+ ,(with-output-to-string (desc) (describe object desc))))
+
+(definterface eval-context (object)
+ "Return a list of bindings corresponding to OBJECT's slots."
+ (declare (ignore object))
+ '())
+
+;;; Utilities for inspector methods.
+;;;
+
+(defun label-value-line (label value &key (newline t))
+ "Create a control list which prints \"LABEL: VALUE\" in the inspector.
+If NEWLINE is non-NIL a `(:newline)' is added to the result."
+ (list* (princ-to-string label) ": " `(:value ,value)
+ (if newline '((:newline)) nil)))
+
+(defmacro label-value-line* (&rest label-values)
+ ` (append ,@(loop for (label value) in label-values
+ collect `(label-value-line ,label ,value))))
+
+(definterface describe-primitive-type (object)
+ "Return a string describing the primitive type of object."
+ (declare (ignore object))
+ "N/A")
+
+
+;;;; Multithreading
+;;;
+;;; The default implementations are sufficient for non-multiprocessing
+;;; implementations.
+
+(definterface initialize-multiprocessing (continuation)
+ "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
+
+Depending on the impleimentaion, this function may never return."
+ (funcall continuation))
+
+(definterface spawn (fn &key name)
+ "Create a new thread to call FN.")
+
+(definterface thread-id (thread)
+ "Return an Emacs-parsable object to identify THREAD.
+
+Ids should be comparable with equal, i.e.:
+ (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
+ thread)
+
+(definterface find-thread (id)
+ "Return the thread for ID.
+ID should be an id previously obtained with THREAD-ID.
+Can return nil if the thread no longer exists."
+ (declare (ignore id))
+ (current-thread))
+
+(definterface thread-name (thread)
+ "Return the name of THREAD.
+Thread names are short strings meaningful to the user. They do not
+have to be unique."
+ (declare (ignore thread))
+ "The One True Thread")
+
+(definterface thread-status (thread)
+ "Return a string describing THREAD's state."
+ (declare (ignore thread))
+ "")
+
+(definterface thread-attributes (thread)
+ "Return a plist of implementation-dependent attributes for THREAD"
+ (declare (ignore thread))
+ '())
+
+(definterface current-thread ()
+ "Return the currently executing thread."
+ 0)
+
+(definterface all-threads ()
+ "Return a fresh list of all threads."
+ '())
+
+(definterface thread-alive-p (thread)
+ "Test if THREAD is termintated."
+ (member thread (all-threads)))
+
+(definterface interrupt-thread (thread fn)
+ "Cause THREAD to execute FN.")
+
+(definterface kill-thread (thread)
+ "Terminate THREAD immediately.
+Don't execute unwind-protected sections, don't raise conditions.
+(Do not pass go, do not collect $200.)"
+ (declare (ignore thread))
+ nil)
+
+(definterface send (thread object)
+ "Send OBJECT to thread THREAD."
+ (declare (ignore thread))
+ object)
+
+(definterface receive (&optional timeout)
+ "Return the next message from current thread's mailbox."
+ (receive-if (constantly t) timeout))
+
+(definterface receive-if (predicate &optional timeout)
+ "Return the first message satisfiying PREDICATE.")
+
+(definterface register-thread (name thread)
+ "Associate the thread THREAD with the symbol NAME.
+The thread can then be retrieved with `find-registered'.
+If THREAD is nil delete the association."
+ (declare (ignore name thread))
+ nil)
+
+(definterface find-registered (name)
+ "Find the thread that was registered for the symbol NAME.
+Return nil if the no thread was registred or if the tread is dead."
+ (declare (ignore name))
+ nil)
+
+(definterface set-default-initial-binding (var form)
+ "Initialize special variable VAR by default with FORM.
+
+Some implementations initialize certain variables in each newly
+created thread. This function sets the form which is used to produce
+the initial value."
+ (set var (eval form)))
+
+;; List of delayed interrupts.
+;; This should only have thread-local bindings, so no init form.
+(defvar *pending-slime-interrupts*)
+
+(defun check-slime-interrupts ()
+ "Execute pending interrupts if any.
+This should be called periodically in operations which
+can take a long time to complete.
+Return a boolean indicating whether any interrupts was processed."
+ (when (and (boundp '*pending-slime-interrupts*)
+ *pending-slime-interrupts*)
+ (funcall (pop *pending-slime-interrupts*))
+ t))
+
+(defvar *interrupt-queued-handler* nil
+ "Function to call on queued interrupts.
+Interrupts get queued when an interrupt occurs while interrupt
+handling is disabled.
+
+Backends can use this function to abort slow operations.")
+
+(definterface wait-for-input (streams &optional timeout)
+ "Wait for input on a list of streams. Return those that are ready.
+STREAMS is a list of streams
+TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams
+which are ready (or have reached end-of-file) without waiting.
+If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
+return nil.
+
+Return :interrupt if an interrupt occurs while waiting.")
+
+
+;;;; Locks
+
+;; Please use locks only in swank-gray.lisp. Locks are too low-level
+;; for our taste.
+
+(definterface make-lock (&key name)
+ "Make a lock for thread synchronization.
+Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
+but that thread may hold it more than once."
+ (declare (ignore name))
+ :null-lock)
+
+(definterface call-with-lock-held (lock function)
+ "Call FUNCTION with LOCK held, queueing if necessary."
+ (declare (ignore lock)
+ (type function function))
+ (funcall function))
+
+
+;;;; Weak datastructures
+
+(definterface make-weak-key-hash-table (&rest args)
+ "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
+ (apply #'make-hash-table args))
+
+(definterface make-weak-value-hash-table (&rest args)
+ "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
+ (apply #'make-hash-table args))
+
+(definterface hash-table-weakness (hashtable)
+ "Return nil or one of :key :value :key-or-value :key-and-value"
+ (declare (ignore hashtable))
+ nil)
+
+
+;;;; Character names
+
+(definterface character-completion-set (prefix matchp)
+ "Return a list of names of characters that match PREFIX."
+ ;; Handle the standard and semi-standard characters.
+ (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
+ "Linefeed" "Return" "Backspace")
+ when (funcall matchp prefix name)
+ collect name))
+
+
+(defparameter *type-specifier-arglists*
+ '((and . (&rest type-specifiers))
+ (array . (&optional element-type dimension-spec))
+ (base-string . (&optional size))
+ (bit-vector . (&optional size))
+ (complex . (&optional type-specifier))
+ (cons . (&optional car-typespec cdr-typespec))
+ (double-float . (&optional lower-limit upper-limit))
+ (eql . (object))
+ (float . (&optional lower-limit upper-limit))
+ (function . (&optional arg-typespec value-typespec))
+ (integer . (&optional lower-limit upper-limit))
+ (long-float . (&optional lower-limit upper-limit))
+ (member . (&rest eql-objects))
+ (mod . (n))
+ (not . (type-specifier))
+ (or . (&rest type-specifiers))
+ (rational . (&optional lower-limit upper-limit))
+ (real . (&optional lower-limit upper-limit))
+ (satisfies . (predicate-symbol))
+ (short-float . (&optional lower-limit upper-limit))
+ (signed-byte . (&optional size))
+ (simple-array . (&optional element-type dimension-spec))
+ (simple-base-string . (&optional size))
+ (simple-bit-vector . (&optional size))
+ (simple-string . (&optional size))
+ (single-float . (&optional lower-limit upper-limit))
+ (simple-vector . (&optional size))
+ (string . (&optional size))
+ (unsigned-byte . (&optional size))
+ (values . (&rest typespecs))
+ (vector . (&optional element-type size))
+ ))
+
+;;; Heap dumps
+
+(definterface save-image (filename &optional restart-function)
+ "Save a heap image to the file FILENAME.
+RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
+
+(definterface background-save-image (filename &key restart-function
+ completion-function)
+ "Request saving a heap image to the file FILENAME.
+RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
+COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")
+
+(defun deinit-log-output ()
+ ;; Can't hang on to an fd-stream from a previous session.
+ (setf *log-output* nil))
+
+
+;;;; Wrapping
+
+(definterface wrap (spec indicator &key before after replace)
+ "Intercept future calls to SPEC and surround them in callbacks.
+
+INDICATOR is a symbol identifying a particular wrapping, and is used
+to differentiate between multiple wrappings.
+
+Implementations intercept calls to SPEC and call, in this order:
+
+* the BEFORE callback, if it's provided, with a single argument set to
+ the list of arguments passed to the intercepted call;
+
+* the original definition of SPEC recursively honouring any wrappings
+ previously established under different values of INDICATOR. If the
+ compatible function REPLACE is provided, call that instead.
+
+* the AFTER callback, if it's provided, with a single set to the list
+ of values returned by the previous call, or, if that call exited
+ non-locally, a single descriptive symbol, like :EXITED-NON-LOCALLY."
+ (declare (ignore indicator))
+ (assert (symbolp spec) nil
+ "The default implementation for WRAP allows only simple names")
+ (assert (null (get spec 'slime-wrap)) nil
+ "The default implementation for WRAP allows a single wrapping")
+ (let* ((saved (symbol-function spec))
+ (replacement (lambda (&rest args)
+ (let (retlist completed)
+ (unwind-protect
+ (progn
+ (when before
+ (funcall before args))
+ (setq retlist (multiple-value-list
+ (apply (or replace
+ saved) args)))
+ (setq completed t)
+ (values-list retlist))
+ (when after
+ (funcall after (if completed
+ retlist
+ :exited-non-locally))))))))
+ (setf (get spec 'slime-wrap) (list saved replacement))
+ (setf (symbol-function spec) replacement))
+ spec)
+
+(definterface unwrap (spec indicator)
+ "Remove from SPEC any wrappings tagged with INDICATOR."
+ (if (wrapped-p spec indicator)
+ (setf (symbol-function spec) (first (get spec 'slime-wrap)))
+ (cerror "All right, so I did"
+ "Hmmm, ~a is not correctly wrapped, you probably redefined it"
+ spec))
+ (setf (get spec 'slime-wrap) nil)
+ spec)
+
+(definterface wrapped-p (spec indicator)
+ "Returns true if SPEC is wrapped with INDICATOR."
+ (declare (ignore indicator))
+ (and (symbolp spec)
+ (let ((prop-value (get spec 'slime-wrap)))
+ (cond ((and prop-value
+ (not (eq (second prop-value)
+ (symbol-function spec))))
+ (warn "~a appears to be incorrectly wrapped" spec)
+ nil)
+ (prop-value t)
+ (t nil)))))
diff --git a/vim/bundle/slimv/slime/swank/ccl.lisp b/vim/bundle/slimv/slime/swank/ccl.lisp
new file mode 100644
index 0000000..66195c5
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/ccl.lisp
@@ -0,0 +1,861 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-ccl.lisp --- SLIME backend for Clozure CL.
+;;;
+;;; Copyright (C) 2003, James Bielman <jamesjb@jamesjb.com>
+;;;
+;;; This program is licensed under the terms of the Lisp Lesser GNU
+;;; Public License, known as the LLGPL, and distributed with Clozure CL
+;;; as the file "LICENSE". The LLGPL consists of a preamble and the
+;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where
+;;; these conflict, the preamble takes precedence.
+;;;
+;;; The LLGPL is also available online at
+;;; http://opensource.franz.com/preamble.html
+
+(defpackage swank/ccl
+ (:use cl swank/backend))
+
+(in-package swank/ccl)
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+ (assert (and (= ccl::*openmcl-major-version* 1)
+ (>= ccl::*openmcl-minor-version* 4))
+ () "This file needs CCL version 1.4 or newer"))
+
+(defimplementation gray-package-name ()
+ "CCL")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (multiple-value-bind (ok err) (ignore-errors (require 'xref))
+ (unless ok
+ (warn "~a~%" err))))
+
+;;; swank-mop
+
+(import-to-swank-mop
+ '( ;; classes
+ cl:standard-generic-function
+ ccl:standard-slot-definition
+ cl:method
+ cl:standard-class
+ ccl:eql-specializer
+ openmcl-mop:finalize-inheritance
+ openmcl-mop:compute-applicable-methods-using-classes
+ ;; standard-class readers
+ openmcl-mop:class-default-initargs
+ openmcl-mop:class-direct-default-initargs
+ openmcl-mop:class-direct-slots
+ openmcl-mop:class-direct-subclasses
+ openmcl-mop:class-direct-superclasses
+ openmcl-mop:class-finalized-p
+ cl:class-name
+ openmcl-mop:class-precedence-list
+ openmcl-mop:class-prototype
+ openmcl-mop:class-slots
+ openmcl-mop:specializer-direct-methods
+ ;; eql-specializer accessors
+ openmcl-mop:eql-specializer-object
+ ;; generic function readers
+ openmcl-mop:generic-function-argument-precedence-order
+ openmcl-mop:generic-function-declarations
+ openmcl-mop:generic-function-lambda-list
+ openmcl-mop:generic-function-methods
+ openmcl-mop:generic-function-method-class
+ openmcl-mop:generic-function-method-combination
+ openmcl-mop:generic-function-name
+ ;; method readers
+ openmcl-mop:method-generic-function
+ openmcl-mop:method-function
+ openmcl-mop:method-lambda-list
+ openmcl-mop:method-specializers
+ openmcl-mop:method-qualifiers
+ ;; slot readers
+ openmcl-mop:slot-definition-allocation
+ openmcl-mop:slot-definition-documentation
+ openmcl-mop:slot-value-using-class
+ openmcl-mop:slot-definition-initargs
+ openmcl-mop:slot-definition-initform
+ openmcl-mop:slot-definition-initfunction
+ openmcl-mop:slot-definition-name
+ openmcl-mop:slot-definition-type
+ openmcl-mop:slot-definition-readers
+ openmcl-mop:slot-definition-writers
+ openmcl-mop:slot-boundp-using-class
+ openmcl-mop:slot-makunbound-using-class))
+
+;;; UTF8
+
+(defimplementation string-to-utf8 (string)
+ (ccl:encode-string-to-octets string :external-format :utf-8))
+
+(defimplementation utf8-to-string (octets)
+ (ccl:decode-string-from-octets octets :external-format :utf-8))
+
+;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defimplementation create-socket (host port &key backlog)
+ (ccl:make-socket :connect :passive :local-port port
+ :local-host host :reuse-address t
+ :backlog (or backlog 5)))
+
+(defimplementation local-port (socket)
+ (ccl:local-port socket))
+
+(defimplementation close-socket (socket)
+ (close socket))
+
+(defimplementation accept-connection (socket &key external-format
+ buffering timeout)
+ (declare (ignore buffering timeout))
+ (let ((stream-args (and external-format
+ `(:external-format ,external-format))))
+ (ccl:accept-connection socket :wait t :stream-args stream-args)))
+
+(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")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defimplementation socket-fd (stream)
+ (ccl::ioblock-device (ccl::stream-ioblock stream t)))
+
+;;; Unix signals
+
+(defimplementation getpid ()
+ (ccl::getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "ccl")
+
+;;; Arglist
+
+(defimplementation arglist (fname)
+ (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil))
+ (ccl:arglist fname))
+ (if binding
+ arglist
+ :not-available)))
+
+(defimplementation function-name (function)
+ (ccl:function-name function))
+
+(defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
+ (let ((flags (ccl:declaration-information decl-identifier)))
+ (if flags
+ `(&any ,flags)
+ (call-next-method))))
+
+;;; Compilation
+
+(defun handle-compiler-warning (condition)
+ "Resignal a ccl:compiler-warning as swank/backend:compiler-warning."
+ (signal 'compiler-condition
+ :original-condition condition
+ :message (compiler-warning-short-message condition)
+ :source-context nil
+ :severity (compiler-warning-severity condition)
+ :location (source-note-to-source-location
+ (ccl:compiler-warning-source-note condition)
+ (lambda () "Unknown source")
+ (ccl:compiler-warning-function-name condition))))
+
+(defgeneric compiler-warning-severity (condition))
+(defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
+(defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning)
+
+(defgeneric compiler-warning-short-message (condition))
+
+;; Pretty much the same as ccl:report-compiler-warning but
+;; without the source position and function name stuff.
+(defmethod compiler-warning-short-message ((c ccl:compiler-warning))
+ (with-output-to-string (stream)
+ (ccl:report-compiler-warning c stream :short t)))
+
+;; Needed because `ccl:report-compiler-warning' would return
+;; "Nonspecific warning".
+(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause))
+ (princ-to-string c))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((ccl:compiler-warning 'handle-compiler-warning))
+ (let ((ccl:*merge-compiler-warnings* nil))
+ (funcall function))))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (compile-file input-file
+ :output-file output-file
+ :load load-p
+ :external-format external-format)))
+
+;; Use a temp file rather than in-core compilation in order to handle
+;; eval-when's as compile-time.
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (let ((temp-file-name (ccl:temp-pathname))
+ (ccl:*save-source-locations* t))
+ (unwind-protect
+ (progn
+ (with-open-file (s temp-file-name :direction :output
+ :if-exists :error :external-format :utf-8)
+ (write-string string s))
+ (let ((binary-filename (compile-temp-file
+ temp-file-name filename buffer position)))
+ (delete-file binary-filename)))
+ (delete-file temp-file-name)))))
+
+(defvar *temp-file-map* (make-hash-table :test #'equal)
+ "A mapping from tempfile names to Emacs buffer names.")
+
+(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
+ (compile-file temp-file-name
+ :load t
+ :compile-file-original-truename
+ (or buffer-file-name
+ (progn
+ (setf (gethash temp-file-name *temp-file-map*)
+ buffer-name)
+ temp-file-name))
+ :compile-file-original-buffer-offset (1- offset)
+ :external-format :utf-8))
+
+(defimplementation save-image (filename &optional restart-function)
+ (ccl:save-application filename :toplevel-function restart-function))
+
+;;; Cross-referencing
+
+(defun xref-locations (relation name &optional inverse)
+ (delete-duplicates
+ (mapcan #'find-definitions
+ (if inverse
+ (ccl::get-relation relation name :wild :exhaustive t)
+ (ccl::get-relation relation :wild name :exhaustive t)))
+ :test 'equal))
+
+(defimplementation who-binds (name)
+ (xref-locations :binds name))
+
+(defimplementation who-macroexpands (name)
+ (xref-locations :macro-calls name t))
+
+(defimplementation who-references (name)
+ (remove-duplicates
+ (append (xref-locations :references name)
+ (xref-locations :sets name)
+ (xref-locations :binds name))
+ :test 'equal))
+
+(defimplementation who-sets (name)
+ (xref-locations :sets name))
+
+(defimplementation who-calls (name)
+ (remove-duplicates
+ (append
+ (xref-locations :direct-calls name)
+ (xref-locations :indirect-calls name)
+ (xref-locations :macro-calls name t))
+ :test 'equal))
+
+(defimplementation who-specializes (class)
+ (when (symbolp class)
+ (setq class (find-class class nil)))
+ (when class
+ (delete-duplicates
+ (mapcar (lambda (m)
+ (car (find-definitions m)))
+ (ccl:specializer-direct-methods class))
+ :test 'equal)))
+
+(defimplementation list-callees (name)
+ (remove-duplicates
+ (append
+ (xref-locations :direct-calls name t)
+ (xref-locations :macro-calls name nil))
+ :test 'equal))
+
+(defimplementation list-callers (symbol)
+ (delete-duplicates
+ (mapcan #'find-definitions (ccl:caller-functions symbol))
+ :test #'equal))
+
+;;; Profiling (alanr: lifted from swank-clisp)
+
+(defimplementation profile (fname)
+ (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro
+
+(defimplementation profiled-functions ()
+ swank-monitor:*monitored-functions*)
+
+(defimplementation unprofile (fname)
+ (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro
+
+(defimplementation unprofile-all ()
+ (swank-monitor:unmonitor))
+
+(defimplementation profile-report ()
+ (swank-monitor:report-monitoring))
+
+(defimplementation profile-reset ()
+ (swank-monitor:reset-all-monitoring))
+
+(defimplementation profile-package (package callers-p methods)
+ (declare (ignore callers-p methods))
+ (swank-monitor:monitor-all package))
+
+;;; Debugging
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let* (;;(*debugger-hook* nil)
+ ;; don't let error while printing error take us down
+ (ccl:*signal-printing-errors* nil))
+ (funcall debugger-loop-fn)))
+
+;; This is called for an async interrupt and is running in a random
+;; thread not selected by the user, so don't use thread-local vars
+;; such as *emacs-connection*.
+(defun find-repl-thread ()
+ (let* ((*break-on-signals* nil)
+ (conn (swank::default-connection)))
+ (and (swank::multithreaded-connection-p conn)
+ (swank::mconn.repl-thread conn))))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (ccl:*break-hook* hook)
+ (ccl:*select-interactive-process-hook* 'find-repl-thread))
+ (funcall fun)))
+
+(defimplementation install-debugger-globally (function)
+ (setq *debugger-hook* function)
+ (setq ccl:*break-hook* function)
+ (setq ccl:*select-interactive-process-hook* 'find-repl-thread)
+ )
+
+(defun map-backtrace (function &optional
+ (start-frame-number 0)
+ end-frame-number)
+ "Call FUNCTION passing information about each stack frame
+ from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
+ (let ((end-frame-number (or end-frame-number most-positive-fixnum)))
+ (ccl:map-call-frames function
+ :origin ccl:*top-error-frame*
+ :start-frame-number start-frame-number
+ :count (- end-frame-number start-frame-number))))
+
+(defimplementation compute-backtrace (start-frame-number end-frame-number)
+ (let (result)
+ (map-backtrace (lambda (p context)
+ (push (list :frame p context) result))
+ start-frame-number end-frame-number)
+ (nreverse result)))
+
+(defimplementation print-frame (frame stream)
+ (assert (eq (first frame) :frame))
+ (destructuring-bind (p context) (rest frame)
+ (let ((lfun (ccl:frame-function p context)))
+ (format stream "(~S" (or (ccl:function-name lfun) lfun))
+ (let* ((unavailable (cons nil nil))
+ (args (ccl:frame-supplied-arguments p context
+ :unknown-marker unavailable)))
+ (declare (dynamic-extent unavailable))
+ (if (eq args unavailable)
+ (format stream " #<Unknown Arguments>")
+ (dolist (arg args)
+ (if (eq arg unavailable)
+ (format stream " #<Unavailable>")
+ (format stream " ~s" arg)))))
+ (format stream ")"))))
+
+(defmacro with-frame ((p context) frame-number &body body)
+ `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
+
+(defun call/frame (frame-number if-found)
+ (map-backtrace
+ (lambda (p context)
+ (return-from call/frame
+ (funcall if-found p context)))
+ frame-number))
+
+(defimplementation frame-call (frame-number)
+ (with-frame (p context) frame-number
+ (with-output-to-string (stream)
+ (print-frame (list :frame p context) stream))))
+
+(defimplementation frame-var-value (frame var)
+ (with-frame (p context) frame
+ (cdr (nth var (ccl:frame-named-variables p context)))))
+
+(defimplementation frame-locals (index)
+ (with-frame (p context) index
+ (loop for (name . value) in (ccl:frame-named-variables p context)
+ collect (list :name name :value value :id 0))))
+
+(defimplementation frame-source-location (index)
+ (with-frame (p context) index
+ (multiple-value-bind (lfun pc) (ccl:frame-function p context)
+ (if pc
+ (pc-source-location lfun pc)
+ (function-source-location lfun)))))
+
+(defun function-name-package (name)
+ (etypecase name
+ (null nil)
+ (symbol (symbol-package name))
+ ((cons (eql ccl::traced)) (function-name-package (second name)))
+ ((cons (eql setf)) (symbol-package (second name)))
+ ((cons (eql :internal)) (function-name-package (car (last name))))
+ ((cons (and symbol (not keyword)) (cons list null))
+ (symbol-package (car name)))
+ (standard-method (function-name-package (ccl:method-name name)))))
+
+(defimplementation frame-package (frame-number)
+ (with-frame (p context) frame-number
+ (let* ((lfun (ccl:frame-function p context))
+ (name (ccl:function-name lfun)))
+ (function-name-package name))))
+
+(defimplementation eval-in-frame (form index)
+ (with-frame (p context) index
+ (let ((vars (ccl:frame-named-variables p context)))
+ (eval `(let ,(loop for (var . val) in vars collect `(,var ',val))
+ (declare (ignorable ,@(mapcar #'car vars)))
+ ,form)))))
+
+(defimplementation return-from-frame (index form)
+ (let ((values (multiple-value-list (eval-in-frame form index))))
+ (with-frame (p context) index
+ (declare (ignore context))
+ (ccl:apply-in-frame p #'values values))))
+
+(defimplementation restart-frame (index)
+ (with-frame (p context) index
+ (ccl:apply-in-frame p
+ (ccl:frame-function p context)
+ (ccl:frame-supplied-arguments p context))))
+
+(defimplementation disassemble-frame (the-frame-number)
+ (with-frame (p context) the-frame-number
+ (multiple-value-bind (lfun pc) (ccl:frame-function p context)
+ (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
+ (disassemble lfun))))
+
+;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
+;; contains some interesting details:
+;;
+;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
+;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
+;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end
+;; positions are file positions (not character positions). The text will
+;; be NIL unless text recording was on at read-time. If the original
+;; file is still available, you can force missing source text to be read
+;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
+;;
+;; Source-note's are associated with definitions (via record-source-file)
+;; and also stored in function objects (including anonymous and nested
+;; functions). The former can be retrieved via
+;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
+;;
+;; The recording behavior is controlled by the new variable
+;; CCL:*SAVE-SOURCE-LOCATIONS*:
+;;
+;; If NIL, don't store source-notes in function objects, and store only
+;; the filename for definitions (the latter only if
+;; *record-source-file* is true).
+;;
+;; If T, store source-notes, including a copy of the original source
+;; text, for function objects and definitions (the latter only if
+;; *record-source-file* is true).
+;;
+;; If :NO-TEXT, store source-notes, but without saved text, for
+;; function objects and defintions (the latter only if
+;; *record-source-file* is true). This is the default.
+;;
+;; PC to source mapping is controlled by the new variable
+;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a
+;; compressed table mapping pc offsets to corresponding source locations.
+;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
+;; which returns a source-note for the source at offset pc in the
+;; function.
+
+(defun function-source-location (function)
+ (source-note-to-source-location
+ (or (ccl:function-source-note function)
+ (function-name-source-note function))
+ (lambda ()
+ (format nil "Function has no source note: ~A" function))
+ (ccl:function-name function)))
+
+(defun pc-source-location (function pc)
+ (source-note-to-source-location
+ (or (ccl:find-source-note-at-pc function pc)
+ (ccl:function-source-note function)
+ (function-name-source-note function))
+ (lambda ()
+ (format nil "No source note at PC: ~a[~d]" function pc))
+ (ccl:function-name function)))
+
+(defun function-name-source-note (fun)
+ (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
+ (and defs
+ (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
+ (declare (ignore type name srclocs))
+ srcloc))))
+
+(defun source-note-to-source-location (source if-nil-thunk &optional name)
+ (labels ((filename-to-buffer (filename)
+ (cond ((gethash filename *temp-file-map*)
+ (list :buffer (gethash filename *temp-file-map*)))
+ ((probe-file filename)
+ (list :file (ccl:native-translated-namestring
+ (truename filename))))
+ (t (error "File ~s doesn't exist" filename)))))
+ (handler-case
+ (cond ((ccl:source-note-p source)
+ (let* ((full-text (ccl:source-note-text source))
+ (file-name (ccl:source-note-filename source))
+ (start-pos (ccl:source-note-start-pos source)))
+ (make-location
+ (when file-name (filename-to-buffer (pathname file-name)))
+ (when start-pos (list :position (1+ start-pos)))
+ (when full-text
+ (list :snippet (subseq full-text 0
+ (min 40 (length full-text))))))))
+ ((and source name)
+ ;; This branch is probably never used
+ (make-location
+ (filename-to-buffer source)
+ (list :function-name (princ-to-string
+ (if (functionp name)
+ (ccl:function-name name)
+ name)))))
+ (t `(:error ,(funcall if-nil-thunk))))
+ (error (c) `(:error ,(princ-to-string c))))))
+
+(defun alphatizer-definitions (name)
+ (let ((alpha (gethash name ccl::*nx1-alphatizers*)))
+ (and alpha (ccl:find-definition-sources alpha))))
+
+(defun p2-definitions (name)
+ (let ((nx1-op (gethash name ccl::*nx1-operators*)))
+ (and nx1-op
+ (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) )
+ (and (array-in-bounds-p dispatch nx1-op)
+ (let ((p2 (aref dispatch nx1-op)))
+ (and p2
+ (ccl:find-definition-sources p2))))))))
+
+(defimplementation find-definitions (name)
+ (let ((defs (append (or (ccl:find-definition-sources name)
+ (and (symbolp name)
+ (fboundp name)
+ (ccl:find-definition-sources
+ (symbol-function name))))
+ (alphatizer-definitions name)
+ (p2-definitions name))))
+ (loop for ((type . name) . sources) in defs
+ collect (list (definition-name type name)
+ (source-note-to-source-location
+ (find-if-not #'null sources)
+ (lambda () "No source-note available")
+ name)))))
+
+(defimplementation find-source-location (obj)
+ (let* ((defs (ccl:find-definition-sources obj))
+ (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
+ (car defs)))
+ (note (find-if-not #'null (cdr best-def))))
+ (when note
+ (source-note-to-source-location
+ note
+ (lambda () "No source note available")))))
+
+(defun definition-name (type object)
+ (case (ccl:definition-type-name type)
+ (method (ccl:name-of object))
+ (t (list (ccl:definition-type-name type) (ccl:name-of object)))))
+
+;;; Utilities
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :function (if (fboundp symbol)
+ (doc 'function)))
+ (maybe-push
+ :setf (let ((setf-function-name (ccl:setf-function-spec-name
+ `(setf ,symbol))))
+ (when (fboundp setf-function-name)
+ (doc 'function setf-function-name))))
+ (maybe-push
+ :type (when (ccl:type-specifier-p symbol)
+ (doc 'type)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:setf
+ (describe (ccl:setf-function-spec-name `(setf ,symbol))))
+ (:class
+ (describe (find-class symbol)))
+ (:type
+ (describe (or (find-class symbol nil) symbol)))))
+
+;; spec ::= (:defmethod <name> {<qualifier>}* ({<specializer>}*))
+(defun parse-defmethod-spec (spec)
+ (values (second spec)
+ (subseq spec 2 (position-if #'consp spec))
+ (find-if #'consp (cddr spec))))
+
+(defimplementation toggle-trace (spec)
+ "We currently ignore just about everything."
+ (let ((what (ecase (first spec)
+ ((setf)
+ spec)
+ ((:defgeneric)
+ (second spec))
+ ((:defmethod)
+ (multiple-value-bind (name qualifiers specializers)
+ (parse-defmethod-spec spec)
+ (find-method (fdefinition name)
+ qualifiers
+ specializers))))))
+ (cond ((member what (trace) :test #'equal)
+ (ccl::%untrace what)
+ (format nil "~S is now untraced." what))
+ (t
+ (ccl:trace-function what)
+ (format nil "~S is now traced." what)))))
+
+;;; Macroexpansion
+
+(defimplementation macroexpand-all (form &optional env)
+ (ccl:macroexpand-all form env))
+
+;;;; Inspection
+
+(defun comment-type-p (type)
+ (or (eq type :comment)
+ (and (consp type) (eq (car type) :comment))))
+
+(defmethod emacs-inspect ((o t))
+ (let* ((inspector:*inspector-disassembly* t)
+ (i (inspector:make-inspector o))
+ (count (inspector:compute-line-count i)))
+ (loop for l from 0 below count append
+ (multiple-value-bind (value label type) (inspector:line-n i l)
+ (etypecase type
+ ((member nil :normal)
+ `(,(or label "") (:value ,value) (:newline)))
+ ((member :colon)
+ (label-value-line label value))
+ ((member :static)
+ (list (princ-to-string label) " " `(:value ,value) '(:newline)))
+ ((satisfies comment-type-p)
+ (list (princ-to-string label) '(:newline))))))))
+
+(defmethod emacs-inspect :around ((o t))
+ (if (or (uvector-inspector-p o)
+ (not (ccl:uvectorp o)))
+ (call-next-method)
+ (let ((value (call-next-method)))
+ (cond ((listp value)
+ (append value
+ `((:newline)
+ (:value ,(make-instance 'uvector-inspector :object o)
+ "Underlying UVECTOR"))))
+ (t value)))))
+
+(defmethod emacs-inspect ((f function))
+ (append
+ (label-value-line "Name" (function-name f))
+ `("Its argument list is: "
+ ,(princ-to-string (arglist f)) (:newline))
+ (label-value-line "Documentation" (documentation f t))
+ (when (function-lambda-expression f)
+ (label-value-line "Lambda Expression"
+ (function-lambda-expression f)))
+ (when (ccl:function-source-note f)
+ (label-value-line "Source note"
+ (ccl:function-source-note f)))
+ (when (typep f 'ccl:compiled-lexical-closure)
+ (append
+ (label-value-line "Inner function" (ccl::closure-function f))
+ '("Closed over values:" (:newline))
+ (loop for (name value) in (ccl::closure-closed-over-values f)
+ append (label-value-line (format nil " ~a" name)
+ value))))))
+
+(defclass uvector-inspector ()
+ ((object :initarg :object)))
+
+(defgeneric uvector-inspector-p (object)
+ (:method ((object t)) nil)
+ (:method ((object uvector-inspector)) t))
+
+(defmethod emacs-inspect ((uv uvector-inspector))
+ (with-slots (object) uv
+ (loop for i below (ccl:uvsize object) append
+ (label-value-line (princ-to-string i) (ccl:uvref object i)))))
+
+(defimplementation type-specifier-p (symbol)
+ (or (ccl:type-specifier-p symbol)
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+;;; Multiprocessing
+
+(defvar *known-processes*
+ (make-hash-table :size 20 :weak :key :test #'eq)
+ "A map from threads to mailboxes.")
+
+(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
+
+(defstruct (mailbox (:conc-name mailbox.))
+ (mutex (ccl:make-lock "thread mailbox"))
+ (semaphore (ccl:make-semaphore))
+ (queue '() :type list))
+
+(defimplementation spawn (fun &key name)
+ (ccl:process-run-function (or name "Anonymous (Swank)")
+ fun))
+
+(defimplementation thread-id (thread)
+ (ccl:process-serial-number thread))
+
+(defimplementation find-thread (id)
+ (find id (ccl:all-processes) :key #'ccl:process-serial-number))
+
+(defimplementation thread-name (thread)
+ (ccl:process-name thread))
+
+(defimplementation thread-status (thread)
+ (format nil "~A" (ccl:process-whostate thread)))
+
+(defimplementation thread-attributes (thread)
+ (list :priority (ccl:process-priority thread)))
+
+(defimplementation make-lock (&key name)
+ (ccl:make-lock name))
+
+(defimplementation call-with-lock-held (lock function)
+ (ccl:with-lock-grabbed (lock)
+ (funcall function)))
+
+(defimplementation current-thread ()
+ ccl:*current-process*)
+
+(defimplementation all-threads ()
+ (ccl:all-processes))
+
+(defimplementation kill-thread (thread)
+ ;;(ccl:process-kill thread) ; doesn't cut it
+ (ccl::process-initial-form-exited thread :kill))
+
+(defimplementation thread-alive-p (thread)
+ (not (ccl:process-exhausted-p thread)))
+
+(defimplementation interrupt-thread (thread function)
+ (ccl:process-interrupt
+ thread
+ (lambda ()
+ (let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
+ (funcall function)))))
+
+(defun mailbox (thread)
+ (ccl:with-lock-grabbed (*known-processes-lock*)
+ (or (gethash thread *known-processes*)
+ (setf (gethash thread *known-processes*) (make-mailbox)))))
+
+(defimplementation send (thread message)
+ (assert message)
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+ (ccl:with-lock-grabbed (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (ccl:signal-semaphore (mailbox.semaphore mbox)))))
+
+(defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox ccl:*current-process*))
+ (mutex (mailbox.mutex mbox)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (ccl:with-lock-grabbed (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)))
+ (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
+
+(let ((alist '())
+ (lock (ccl:make-lock "register-thread")))
+
+ (defimplementation register-thread (name thread)
+ (declare (type symbol name))
+ (ccl:with-lock-grabbed (lock)
+ (etypecase thread
+ (null
+ (setf alist (delete name alist :key #'car)))
+ (ccl:process
+ (let ((probe (assoc name alist)))
+ (cond (probe (setf (cdr probe) thread))
+ (t (setf alist (acons name thread alist))))))))
+ nil)
+
+ (defimplementation find-registered (name)
+ (ccl:with-lock-grabbed (lock)
+ (cdr (assoc name alist)))))
+
+(defimplementation set-default-initial-binding (var form)
+ (eval `(ccl::def-standard-initial-binding ,var ,form)))
+
+(defimplementation quit-lisp ()
+ (ccl:quit))
+
+(defimplementation set-default-directory (directory)
+ (let ((dir (truename (merge-pathnames directory))))
+ (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
+ (ccl:cwd dir)
+ (default-directory)))
+
+;;; Weak datastructures
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak :key args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ (apply #'make-hash-table :weak :value args))
+
+(defimplementation hash-table-weakness (hashtable)
+ (ccl:hash-table-weak-p hashtable))
+
+(pushnew 'deinit-log-output ccl:*save-exit-functions*)
diff --git a/vim/bundle/slimv/slime/swank/clasp.lisp b/vim/bundle/slimv/slime/swank/clasp.lisp
new file mode 100644
index 0000000..3e0c4ef
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/clasp.lisp
@@ -0,0 +1,730 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-clasp.lisp --- SLIME backend for CLASP.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+;;; Administrivia
+
+(defpackage swank/clasp
+ (:use cl swank/backend))
+
+(in-package swank/clasp)
+
+
+(defmacro cslime-log (fmt &rest fmt-args)
+ `(format t ,fmt ,@fmt-args))
+
+;; Hard dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'sockets))
+
+;; Soft dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (probe-file "sys:profile.fas")
+ (require :profile)
+ (pushnew :profile *features*))
+ (when (probe-file "sys:serve-event")
+ (require :serve-event)
+ (pushnew :serve-event *features*)))
+
+(declaim (optimize (debug 3)))
+
+;;; Swank-mop
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import-swank-mop-symbols
+ :clos
+ `(:eql-specializer
+ :eql-specializer-object
+ :generic-function-declarations
+ :specializer-direct-methods
+ ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes)
+ '(:compute-applicable-methods-using-classes)))))
+
+(defimplementation gray-package-name ()
+ "GRAY")
+
+
+;;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ ;; CLASP does not provide threads yet.
+ ;; ECLs swank implementation says that CLOS is not thread safe and
+ ;; I use ECLs CLOS implementation - this is a worry for the future.
+ nil
+ )
+
+(defun resolve-hostname (name)
+ (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port &key backlog)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket (resolve-hostname host) 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-bsd-sockets:socket-close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format
+ buffering timeout)
+ (declare (ignore timeout))
+ (sb-bsd-sockets:socket-make-stream (accept socket)
+ :output t
+ :input t
+ :buffering (ecase buffering
+ ((t) :full)
+ ((nil) :none)
+ (:line :line))
+ :element-type (if external-format
+ 'character
+ '(unsigned-byte 8))
+ :external-format external-format))
+(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 ()))))
+
+(defimplementation socket-fd (socket)
+ (etypecase socket
+ (fixnum socket)
+ (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
+ (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
+ (file-stream (si:file-stream-fd socket))))
+
+(defvar *external-format-to-coding-system*
+ '((:latin-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")))
+
+(defun external-format (coding-system)
+ (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*))
+ (find coding-system (ext:all-encodings) :test #'string-equal)))
+
+(defimplementation find-external-format (coding-system)
+ #+unicode (external-format coding-system)
+ ;; Without unicode support, CLASP uses the one-byte encoding of the
+ ;; underlying OS, and will barf on anything except :DEFAULT. We
+ ;; return NIL here for known multibyte encodings, so
+ ;; SWANK:CREATE-SERVER will barf.
+ #-unicode (let ((xf (external-format coding-system)))
+ (if (member xf '(:utf-8))
+ nil
+ :default)))
+
+
+;;;; Unix Integration
+
+;;; If CLASP is built with thread support, it'll spawn a helper thread
+;;; executing the SIGINT handler. We do not want to BREAK into that
+;;; helper but into the main thread, though. This is coupled with the
+;;; current choice of NIL as communication-style in so far as CLASP's
+;;; main-thread is also the Slime's REPL thread.
+
+#+clasp-working
+(defimplementation call-with-user-break-handler (real-handler function)
+ (let ((old-handler #'si:terminal-interrupt))
+ (setf (symbol-function 'si:terminal-interrupt)
+ (make-interrupt-handler real-handler))
+ (unwind-protect (funcall function)
+ (setf (symbol-function 'si:terminal-interrupt) old-handler))))
+
+#+threads
+(defun make-interrupt-handler (real-handler)
+ (let ((main-thread (find 'si:top-level (mp:all-processes)
+ :key #'mp:process-name)))
+ #'(lambda (&rest args)
+ (declare (ignore args))
+ (mp:interrupt-process main-thread real-handler))))
+
+#-threads
+(defun make-interrupt-handler (real-handler)
+ #'(lambda (&rest args)
+ (declare (ignore args))
+ (funcall real-handler)))
+
+
+(defimplementation getpid ()
+ (si:getpid))
+
+(defimplementation set-default-directory (directory)
+ (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (ext:getcwd)))
+
+(defimplementation quit-lisp ()
+ (core:quit))
+
+
+
+;;; Instead of busy waiting with communication-style NIL, use select()
+;;; on the sockets' streams.
+#+serve-event
+(progn
+ (defun poll-streams (streams timeout)
+ (let* ((serve-event::*descriptor-handlers*
+ (copy-list serve-event::*descriptor-handlers*))
+ (active-fds '())
+ (fd-stream-alist
+ (loop for s in streams
+ for fd = (socket-fd s)
+ collect (cons fd s)
+ do (serve-event:add-fd-handler fd :input
+ #'(lambda (fd)
+ (push fd active-fds))))))
+ (serve-event:serve-event timeout)
+ (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))
+
+ (defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (cond ((check-slime-interrupts) (return :interrupt))
+ (timeout (return (poll-streams streams 0)))
+ (t
+ (when-let (ready (poll-streams streams 0.2))
+ (return ready))))))
+
+) ; #+serve-event (progn ...
+
+#-serve-event
+(defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (cond ((check-slime-interrupts) (return :interrupt))
+ (timeout (return (remove-if-not #'listen streams)))
+ (t
+ (let ((ready (remove-if-not #'listen streams)))
+ (if ready (return ready))
+ (sleep 0.1))))))
+
+
+;;;; Compilation
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+
+(defun signal-compiler-condition (&rest args)
+ (apply #'signal 'compiler-condition args))
+
+#-clasp-bytecmp
+(defun handle-compiler-message (condition)
+ ;; CLASP emits lots of noise in compiler-notes, like "Invoking
+ ;; external command".
+ (unless (typep condition 'c::compiler-note)
+ (signal-compiler-condition
+ :original-condition condition
+ :message (princ-to-string condition)
+ :severity (etypecase condition
+ (cmp:compiler-fatal-error :error)
+ (cmp:compiler-error :error)
+ (error :error)
+ (style-warning :style-warning)
+ (warning :warning))
+ :location (condition-location condition))))
+
+#-clasp-bytecmp
+(defun condition-location (condition)
+ (let ((file (cmp:compiler-message-file condition))
+ (position (cmp:compiler-message-file-position condition)))
+ (if (and position (not (minusp position)))
+ (if *buffer-name*
+ (make-buffer-location *buffer-name*
+ *buffer-start-position*
+ position)
+ (make-file-location file position))
+ (make-error-location "No location found."))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (funcall function))
+#|| #-clasp-bytecmp
+ (handler-bind ((c:compiler-message #'handle-compiler-message))
+ (funcall function)))
+||#
+
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file)
+ ;; Ignore the output-file and generate our own
+ (let ((tmp-output-file (compile-file-pathname (si:mkstemp "TMP:clasp-swank-compile-file-"))))
+ (format t "Using tmp-output-file: ~a~%" tmp-output-file)
+ (multiple-value-bind (fasl warnings-p failure-p)
+ (with-compilation-hooks ()
+ (compile-file input-file :output-file tmp-output-file
+ :external-format external-format))
+ (values fasl warnings-p
+ (or failure-p
+ (when load-p
+ (not (load fasl))))))))
+
+(defvar *tmpfile-map* (make-hash-table :test #'equal))
+
+(defun note-buffer-tmpfile (tmp-file buffer-name)
+ ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
+ (let ((tmp-namestring (namestring (truename tmp-file))))
+ (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
+ tmp-namestring))
+
+(defun tmpfile-to-buffer (tmp-file)
+ (gethash tmp-file *tmpfile-map*))
+
+(defimplementation swank-compile-string (string &key buffer position filename policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer) ; for compilation hooks
+ (*buffer-start-position* position))
+ (let ((tmp-file (si:mkstemp "TMP:clasp-swank-tmpfile-"))
+ (fasl-file)
+ (warnings-p)
+ (failure-p))
+ (unwind-protect
+ (with-open-file (tmp-stream tmp-file :direction :output
+ :if-exists :supersede)
+ (write-string string tmp-stream)
+ (finish-output tmp-stream)
+ (multiple-value-setq (fasl-file warnings-p failure-p)
+ (let ((truename (or filename (note-buffer-tmpfile tmp-file buffer))))
+ (compile-file tmp-file
+ :source-debug-namestring truename
+ :source-debug-offset (1- position)))))
+ (when fasl-file (load fasl-file))
+ (when (probe-file tmp-file)
+ (delete-file tmp-file))
+ (when fasl-file
+ (delete-file fasl-file)))
+ (not failure-p)))))
+
+;;;; Documentation
+
+(defimplementation arglist (name)
+ (multiple-value-bind (arglist foundp)
+ (core:function-lambda-list name) ;; Uses bc-split
+ (if foundp arglist :not-available)))
+
+(defimplementation function-name (f)
+ (typecase f
+ (generic-function (clos::generic-function-name f))
+ (function (ext:compiled-function-name f))))
+
+;; FIXME
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (macroexpand form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((frob (type boundp)
+ (when (funcall boundp symbol)
+ (let ((doc (describe-definition symbol type)))
+ (setf result (list* type doc result))))))
+ (frob :VARIABLE #'boundp)
+ (frob :FUNCTION #'fboundp)
+ (frob :CLASS (lambda (x) (find-class x nil))))
+ result))
+
+(defimplementation describe-definition (name type)
+ (case type
+ (:variable (documentation name 'variable))
+ (:function (documentation name 'function))
+ (:class (documentation name 'class))
+ (t nil)))
+
+(defimplementation type-specifier-p (symbol)
+ (or (subtypep nil symbol)
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+
+;;; Debugging
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import
+ '(si::*break-env*
+ si::*ihs-top*
+ si::*ihs-current*
+ si::*ihs-base*
+#+frs si::*frs-base*
+#+frs si::*frs-top*
+ si::*tpl-commands*
+ si::*tpl-level*
+#+frs si::frs-top
+ si::ihs-top
+ si::ihs-fun
+ si::ihs-env
+#+frs si::sch-frs-base
+ si::set-break-env
+ si::set-current-ihs
+ si::tpl-commands)))
+
+(defun make-invoke-debugger-hook (hook)
+ (when hook
+ #'(lambda (condition old-hook)
+ ;; Regard *debugger-hook* if set by user.
+ (if *debugger-hook*
+ nil ; decline, *DEBUGGER-HOOK* will be tried next.
+ (funcall hook condition old-hook)))))
+
+(defimplementation install-debugger-globally (function)
+ (setq *debugger-hook* function)
+ (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))
+ )
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
+ (funcall fun))
+ )
+
+(defvar *backtrace* '())
+
+;;; Commented out; it's not clear this is a good way of doing it. In
+;;; particular because it makes errors stemming from this file harder
+;;; to debug, and given the "young" age of CLASP's swank backend, that's
+;;; a bad idea.
+
+;; (defun in-swank-package-p (x)
+;; (and
+;; (symbolp x)
+;; (member (symbol-package x)
+;; (list #.(find-package :swank)
+;; #.(find-package :swank/backend)
+;; #.(ignore-errors (find-package :swank-mop))
+;; #.(ignore-errors (find-package :swank-loader))))
+;; t))
+
+;; (defun is-swank-source-p (name)
+;; (setf name (pathname name))
+;; (pathname-match-p
+;; name
+;; (make-pathname :defaults swank-loader::*source-directory*
+;; :name (pathname-name name)
+;; :type (pathname-type name)
+;; :version (pathname-version name))))
+
+;; (defun is-ignorable-fun-p (x)
+;; (or
+;; (in-swank-package-p (frame-name x))
+;; (multiple-value-bind (file position)
+;; (ignore-errors (si::bc-file (car x)))
+;; (declare (ignore position))
+;; (if file (is-swank-source-p file)))))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (declare (type function debugger-loop-fn))
+ (let* ((*ihs-top* (or #+#.(swank/backend:with-symbol '*stack-top-hint* 'core)
+ core:*stack-top-hint*
+ (ihs-top)))
+ (*ihs-current* *ihs-top*)
+#+frs (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
+#+frs (*frs-top* (frs-top))
+ (*tpl-level* (1+ *tpl-level*))
+ (*backtrace* (loop for ihs from 0 below *ihs-top*
+ collect (list (si::ihs-fun ihs)
+ (si::ihs-env ihs)
+ ihs))))
+ (declare (special *ihs-current*))
+#+frs (loop for f from *frs-base* until *frs-top*
+ do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
+ (when (plusp i)
+ (let* ((x (elt *backtrace* i))
+ (name (si::frs-tag f)))
+ (unless (si::fixnump name)
+ (push name (third x)))))))
+ (setf *backtrace* (nreverse *backtrace*))
+ (set-break-env)
+ (set-current-ihs)
+ (let ((*ihs-base* *ihs-top*))
+ (funcall debugger-loop-fn))))
+
+(defimplementation compute-backtrace (start end)
+ (subseq *backtrace* start
+ (and (numberp end)
+ (min end (length *backtrace*)))))
+
+(defun frame-name (frame)
+ (let ((x (first frame)))
+ (if (symbolp x)
+ x
+ (function-name x))))
+
+(defun frame-function (frame-number)
+ (let ((x (first (elt *backtrace* frame-number))))
+ (etypecase x
+ (symbol
+ (and (fboundp x)
+ (fdefinition x)))
+ (function
+ x))))
+
+(defimplementation print-frame (frame stream)
+ (format stream "(~s~{ ~s~})" (function-name (first frame))
+ #+#.(swank/backend:with-symbol 'ihs-arguments 'core)
+ (coerce (core:ihs-arguments (third frame)) 'list)
+ #-#.(swank/backend:with-symbol 'ihs-arguments 'core)
+ nil))
+
+(defimplementation frame-source-location (frame-number)
+ (source-location (frame-function frame-number)))
+
+#+clasp-working
+(defimplementation frame-catch-tags (frame-number)
+ (third (elt *backtrace* frame-number)))
+
+(defun ihs-frame-id (frame-number)
+ (- (core:ihs-top) frame-number))
+
+(defimplementation frame-locals (frame-number)
+ (let* ((frame (elt *backtrace* frame-number))
+ (env (second frame))
+ (locals (loop for x = env then (core:get-parent-environment x)
+ while x
+ nconc (loop for name across (core:environment-debug-names x)
+ for value across (core:environment-debug-values x)
+ collect (list :name name :id 0 :value value)))))
+ (nconc
+ (loop for arg across (core:ihs-arguments (third frame))
+ for i from 0
+ collect (list :name (intern (format nil "ARG~d" i) #.*package*)
+ :id 0
+ :value arg))
+ locals)))
+
+(defimplementation frame-var-value (frame-number var-number)
+ (let* ((frame (elt *backtrace* frame-number))
+ (env (second frame))
+ (args (core:ihs-arguments (third frame))))
+ (if (< var-number (length args))
+ (svref args var-number)
+ (elt (frame-locals frame-number) var-number))))
+
+#+clasp-working
+(defimplementation disassemble-frame (frame-number)
+ (let ((fun (frame-function frame-number)))
+ (disassemble fun)))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((env (second (elt *backtrace* frame-number))))
+ (core:compile-form-and-eval-with-env form env)))
+
+#+clasp-working
+(defimplementation gdb-initial-commands ()
+ ;; These signals are used by the GC.
+ #+linux '("handle SIGPWR noprint nostop"
+ "handle SIGXCPU noprint nostop"))
+
+#+clasp-working
+(defimplementation command-line-args ()
+ (loop for n from 0 below (si:argc) collect (si:argv n)))
+
+
+;;;; Inspector
+
+;;; FIXME: Would be nice if it was possible to inspect objects
+;;; implemented in C.
+
+
+;;;; Definitions
+
+(defun make-file-location (file file-position)
+ ;; File positions in CL start at 0, but Emacs' buffer positions
+ ;; start at 1. We specify (:ALIGN T) because the positions comming
+ ;; from CLASP point at right after the toplevel form appearing before
+ ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
+ (make-location `(:file ,(namestring (translate-logical-pathname file)))
+ `(:position ,(1+ file-position))
+ `(:align t)))
+
+(defun make-buffer-location (buffer-name start-position &optional (offset 0))
+ (make-location `(:buffer ,buffer-name)
+ `(:offset ,start-position ,offset)
+ `(:align t)))
+
+(defun translate-location (location)
+ (make-location (list :file (namestring (ext:source-location-pathname location)))
+ (list :position (ext:source-location-offset location))
+ '(:align t)))
+
+(defimplementation find-definitions (name)
+ (loop for kind in ext:*source-location-kinds*
+ for locations = (ext:source-location name kind)
+ when locations
+ nconc (loop for location in locations
+ collect (list kind (translate-location location)))))
+
+(defun source-location (object)
+ (let ((location (ext:source-location object t)))
+ (when location
+ (translate-location (car location)))))
+
+(defimplementation find-source-location (object)
+ (or (source-location object)
+ (make-error-location "Source definition of ~S not found." object)))
+
+
+;;;; Profiling
+
+#+profile
+(progn
+
+(defimplementation profile (fname)
+ (when fname (eval `(profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+ (when fname (eval `(profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+ (profile:unprofile-all)
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (profile:report))
+
+(defimplementation profile-reset ()
+ (profile:reset)
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ (profile:profile))
+
+(defimplementation profile-package (package callers methods)
+ (declare (ignore callers methods))
+ (eval `(profile:profile ,(package-name (find-package package)))))
+) ; #+profile (progn ...
+
+
+;;;; Threads
+
+#+threads
+(progn
+ (defvar *thread-id-counter* 0)
+
+ (defparameter *thread-id-map* (make-hash-table))
+
+ (defvar *thread-id-map-lock*
+ (mp:make-lock :name "thread id map lock"))
+
+ (defimplementation spawn (fn &key name)
+ (mp:process-run-function name fn))
+
+ (defimplementation thread-id (target-thread)
+ (block thread-id
+ (mp:with-lock (*thread-id-map-lock*)
+ ;; Does TARGET-THREAD have an id already?
+ (maphash (lambda (id thread-pointer)
+ (let ((thread (si:weak-pointer-value thread-pointer)))
+ (cond ((not thread)
+ (remhash id *thread-id-map*))
+ ((eq thread target-thread)
+ (return-from thread-id id)))))
+ *thread-id-map*)
+ ;; TARGET-THREAD not found in *THREAD-ID-MAP*
+ (let ((id (incf *thread-id-counter*))
+ (thread-pointer (si:make-weak-pointer target-thread)))
+ (setf (gethash id *thread-id-map*) thread-pointer)
+ id))))
+
+ (defimplementation find-thread (id)
+ (mp:with-lock (*thread-id-map-lock*)
+ (let* ((thread-ptr (gethash id *thread-id-map*))
+ (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
+ (unless thread
+ (remhash id *thread-id-map*))
+ thread)))
+
+ (defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+ (defimplementation thread-status (thread)
+ (if (mp:process-active-p thread)
+ "RUNNING"
+ "STOPPED"))
+
+ (defimplementation make-lock (&key name)
+ (mp:make-lock :name name :recursive t))
+
+ (defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (mp:with-lock (lock) (funcall function)))
+
+ (defimplementation current-thread ()
+ mp:*current-process*)
+
+ (defimplementation all-threads ()
+ (mp:all-processes))
+
+ (defimplementation interrupt-thread (thread fn)
+ (mp:interrupt-process thread fn))
+
+ (defimplementation kill-thread (thread)
+ (mp:process-kill thread))
+
+ (defimplementation thread-alive-p (thread)
+ (mp:process-active-p thread))
+
+ (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
+ (defvar *mailboxes* (list))
+ (declaim (type list *mailboxes*))
+
+ (defstruct (mailbox (:conc-name mailbox.))
+ thread
+ (mutex (mp:make-lock))
+ (cvar (mp:make-condition-variable))
+ (queue '() :type list))
+
+ (defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-lock (*mailbox-lock*)
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+ (defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+ (mp:with-lock (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
+
+ (defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox (current-thread)))
+ (mutex (mailbox.mutex mbox)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (mp:with-lock (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)))
+ (mp:condition-variable-timedwait (mailbox.cvar mbox)
+ mutex
+ 0.2)))))
+
+ ) ; #+threads (progn ...
+
+
+(defmethod emacs-inspect ((object core:cxx-object))
+ (let ((encoded (core:encode object)))
+ (loop for (key . value) in encoded
+ append (list (string key) ": " (list :value value) (list :newline)))))
diff --git a/vim/bundle/slimv/slime/swank/clisp.lisp b/vim/bundle/slimv/slime/swank/clisp.lisp
new file mode 100644
index 0000000..27ae688
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/clisp.lisp
@@ -0,0 +1,930 @@
+;;;; -*- indent-tabs-mode: nil -*-
+
+;;;; SWANK support for CLISP.
+
+;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
+
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License as
+;;;; published by the Free Software Foundation; either version 2 of
+;;;; the License, or (at your option) any later version.
+
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with this program; if not, write to the Free
+;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+;;;; MA 02111-1307, USA.
+
+;;; This is work in progress, but it's already usable. Many things
+;;; are adapted from other swank-*.lisp, in particular from
+;;; swank-allegro (I don't use allegro at all, but it's the shortest
+;;; one and I found Helmut Eller's code there enlightening).
+
+;;; This code will work better with recent versions of CLISP (say, the
+;;; last release or CVS HEAD) while it may not work at all with older
+;;; versions. It is reasonable to expect it to work on platforms with
+;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
+;;; systems, but also on Win32. This backend uses the portable xref
+;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
+;;; are conveniently included in SLIME.
+
+;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
+
+(defpackage swank/clisp
+ (:use cl swank/backend))
+
+(in-package swank/clisp)
+
+(eval-when (:compile-toplevel)
+ (unless (string< "2.44" (lisp-implementation-version))
+ (error "Need at least CLISP version 2.44")))
+
+(defimplementation gray-package-name ()
+ "GRAY")
+
+;;;; if this lisp has the complete CLOS then we use it, otherwise we
+;;;; build up a "fake" swank-mop and then override the methods in the
+;;;; inspector.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *have-mop*
+ (and (find-package :clos)
+ (eql :external
+ (nth-value 1 (find-symbol (string ':standard-slot-definition)
+ :clos))))
+ "True in those CLISP images which have a complete MOP implementation."))
+
+#+#.(cl:if swank/clisp::*have-mop* '(cl:and) '(cl:or))
+(progn
+ (import-swank-mop-symbols :clos '(:slot-definition-documentation))
+
+ (defun swank-mop:slot-definition-documentation (slot)
+ (clos::slot-definition-documentation slot)))
+
+#-#.(cl:if swank/clisp::*have-mop* '(and) '(or))
+(defclass swank-mop:standard-slot-definition ()
+ ()
+ (:documentation
+ "Dummy class created so that swank.lisp will compile and load."))
+
+(let ((getpid (or (find-symbol "PROCESS-ID" :system)
+ ;; old name prior to 2005-03-01, clisp <= 2.33.2
+ (find-symbol "PROGRAM-ID" :system)
+ #+win32 ; integrated into the above since 2005-02-24
+ (and (find-package :win32) ; optional modules/win32
+ (find-symbol "GetCurrentProcessId" :win32)))))
+ (defimplementation getpid () ; a required interface
+ (cond
+ (getpid (funcall getpid))
+ #+win32 ((ext:getenv "PID")) ; where does that come from?
+ (t -1))))
+
+(defimplementation call-with-user-break-handler (handler function)
+ (handler-bind ((system::simple-interrupt-condition
+ (lambda (c)
+ (declare (ignore c))
+ (funcall handler)
+ (when (find-restart 'socket-status)
+ (invoke-restart (find-restart 'socket-status)))
+ (continue))))
+ (funcall function)))
+
+(defimplementation lisp-implementation-type-name ()
+ "clisp")
+
+(defimplementation set-default-directory (directory)
+ (setf (ext:default-directory) directory)
+ (namestring (setf *default-pathname-defaults* (ext:default-directory))))
+
+(defimplementation filename-to-pathname (string)
+ (cond ((member :cygwin *features*)
+ (parse-cygwin-filename string))
+ (t (parse-namestring string))))
+
+(defun parse-cygwin-filename (string)
+ (multiple-value-bind (match _ drive absolute)
+ (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t)
+ (declare (ignore _))
+ (assert (and match (if drive absolute t)) ()
+ "Invalid filename syntax: ~a" string)
+ (let* ((sans-prefix (subseq string (regexp:match-end match)))
+ (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix)))
+ (path (loop for name in path collect
+ (cond ((equal name "..") ':back)
+ (t name))))
+ (directoryp (or (equal string "")
+ (find (aref string (1- (length string))) "\\/"))))
+ (multiple-value-bind (file type)
+ (cond ((and (not directoryp) (last path))
+ (let* ((file (car (last path)))
+ (pos (position #\. file :from-end t)))
+ (cond ((and pos (> pos 0))
+ (values (subseq file 0 pos)
+ (subseq file (1+ pos))))
+ (t file)))))
+ (make-pathname :host nil
+ :device nil
+ :directory (cons
+ (if absolute :absolute :relative)
+ (let ((path (if directoryp
+ path
+ (butlast path))))
+ (if drive
+ (cons
+ (regexp:match-string string drive)
+ path)
+ path)))
+ :name file
+ :type type)))))
+
+;;;; UTF
+
+(defimplementation string-to-utf8 (string)
+ (let ((enc (load-time-value
+ (ext:make-encoding :charset "utf-8" :line-terminator :unix)
+ t)))
+ (ext:convert-string-to-bytes string enc)))
+
+(defimplementation utf8-to-string (octets)
+ (let ((enc (load-time-value
+ (ext:make-encoding :charset "utf-8" :line-terminator :unix)
+ t)))
+ (ext:convert-string-from-bytes octets enc)))
+
+;;;; TCP Server
+
+(defimplementation create-socket (host port &key backlog)
+ (socket:socket-server port :interface host :backlog (or backlog 5)))
+
+(defimplementation local-port (socket)
+ (socket:socket-server-port socket))
+
+(defimplementation close-socket (socket)
+ (socket:socket-server-close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout))
+ (socket:socket-accept socket
+ :buffered buffering ;; XXX may not work if t
+ :element-type (if external-format
+ 'character
+ '(unsigned-byte 8))
+ :external-format (or external-format :default)))
+
+#-win32
+(defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
+ (loop
+ (cond ((check-slime-interrupts) (return :interrupt))
+ (timeout
+ (socket:socket-status streams 0 0)
+ (return (loop for (s nil . x) in streams
+ if x collect s)))
+ (t
+ (with-simple-restart (socket-status "Return from socket-status.")
+ (socket:socket-status streams 0 500000))
+ (let ((ready (loop for (s nil . x) in streams
+ if x collect s)))
+ (when ready (return ready))))))))
+
+#+win32
+(defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (cond ((check-slime-interrupts) (return :interrupt))
+ (t
+ (let ((ready (remove-if-not #'input-available-p streams)))
+ (when ready (return ready)))
+ (when timeout (return nil))
+ (sleep 0.1)))))
+
+#+win32
+;; Some facts to remember (for the next time we need to debug this):
+;; - interactive-sream-p returns t for socket-streams
+;; - listen returns nil for socket-streams
+;; - (type-of <socket-stream>) is 'stream
+;; - (type-of *terminal-io*) is 'two-way-stream
+;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8)
+;; - calling socket:socket-status on non sockets signals an error,
+;; but seems to mess up something internally.
+;; - calling read-char-no-hang on sockets does not signal an error,
+;; but seems to mess up something internally.
+(defun input-available-p (stream)
+ (case (stream-element-type stream)
+ (character
+ (let ((c (read-char-no-hang stream nil nil)))
+ (cond ((not c)
+ nil)
+ (t
+ (unread-char c stream)
+ t))))
+ (t
+ (eq (socket:socket-status (cons stream :input) 0 0)
+ :input))))
+
+;;;; Coding systems
+
+(defvar *external-format-to-coding-system*
+ '(((:charset "iso-8859-1" :line-terminator :unix)
+ "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
+ ((:charset "iso-8859-1")
+ "latin-1" "iso-latin-1" "iso-8859-1")
+ ((:charset "utf-8") "utf-8")
+ ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
+ ((:charset "euc-jp") "euc-jp")
+ ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
+ ((:charset "us-ascii") "us-ascii")
+ ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (let ((args (car (rassoc-if (lambda (x)
+ (member coding-system x :test #'equal))
+ *external-format-to-coding-system*))))
+ (and args (apply #'ext:make-encoding args))))
+
+
+;;;; Swank functions
+
+(defimplementation arglist (fname)
+ (block nil
+ (or (ignore-errors
+ (let ((exp (function-lambda-expression fname)))
+ (and exp (return (second exp)))))
+ (ignore-errors
+ (return (ext:arglist fname)))
+ :not-available)))
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (ext:expand-form form))
+
+(defimplementation collect-macro-forms (form &optional env)
+ ;; Currently detects only normal macros, not compiler macros.
+ (declare (ignore env))
+ (with-collected-macro-forms (macro-forms)
+ (handler-bind ((warning #'muffle-warning))
+ (ignore-errors
+ (compile nil `(lambda () ,form))))
+ (values macro-forms nil)))
+
+(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 (when (boundp symbol) (doc 'variable)))
+ (when (fboundp symbol)
+ (maybe-push
+ ;; Report WHEN etc. as macros, even though they may be
+ ;; implemented as special operators.
+ (if (macro-function symbol) :macro
+ (typecase (fdefinition symbol)
+ (generic-function :generic-function)
+ (function :function)
+ ;; (type-of 'progn) -> ext:special-operator
+ (t :special-operator)))
+ (doc 'function)))
+ (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
+ (get symbol 'system::setf-expander)); defsetf
+ (maybe-push :setf (doc 'setf)))
+ (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
+ (get symbol 'system::defstruct-description)
+ (get symbol 'system::deftype-expander))
+ (maybe-push :type (doc 'type))) ; even for 'structure
+ (when (find-class symbol nil)
+ (maybe-push :class (doc 'type)))
+ ;; Let this code work compiled in images without FFI
+ (let ((types (load-time-value
+ (and (find-package "FFI")
+ (symbol-value
+ (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
+ ;; Use ffi::*c-type-table* so as not to suffer the overhead of
+ ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
+ ;; which are not FFI type names.
+ (when (and types (nth-value 1 (gethash symbol types)))
+ ;; Maybe use (case (head (ffi:deparse-c-type)))
+ ;; to distinguish struct and union types?
+ (maybe-push :alien-type :not-documented)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable (describe symbol))
+ (:macro (describe (macro-function symbol)))
+ (:function (describe (symbol-function symbol)))
+ (:class (describe (find-class symbol)))))
+
+(defimplementation type-specifier-p (symbol)
+ (or (ignore-errors
+ (subtypep nil symbol))
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+(defun fspec-pathname (spec)
+ (let ((path spec)
+ type
+ lines)
+ (when (consp path)
+ (psetq type (car path)
+ path (cadr path)
+ lines (cddr path)))
+ (when (and path
+ (member (pathname-type path)
+ custom:*compiled-file-types* :test #'equal))
+ (setq path
+ (loop for suffix in custom:*source-file-types*
+ thereis (probe-file (make-pathname :defaults path
+ :type suffix)))))
+ (values path type lines)))
+
+(defun fspec-location (name fspec)
+ (multiple-value-bind (file type lines)
+ (fspec-pathname fspec)
+ (list (if type (list name type) name)
+ (cond (file
+ (multiple-value-bind (truename c)
+ (ignore-errors (truename file))
+ (cond (truename
+ (make-location
+ (list :file (namestring truename))
+ (if (consp lines)
+ (list* :line lines)
+ (list :function-name (string name)))
+ (when (consp type)
+ (list :snippet (format nil "~A" type)))))
+ (t (list :error (princ-to-string c))))))
+ (t (list :error
+ (format nil "No source information available for: ~S"
+ fspec)))))))
+
+(defimplementation find-definitions (name)
+ (mapcar #'(lambda (e) (fspec-location name e))
+ (documentation name 'sys::file)))
+
+(defun trim-whitespace (string)
+ (string-trim #(#\newline #\space #\tab) string))
+
+(defvar *sldb-backtrace*)
+
+(defun sldb-backtrace ()
+ "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
+ (let* ((modes '((:all-stack-elements 1)
+ (:all-frames 2)
+ (:only-lexical-frames 3)
+ (:only-eval-and-apply-frames 4)
+ (:only-apply-frames 5)))
+ (mode (cadr (assoc :all-stack-elements modes))))
+ (do ((frames '())
+ (last nil frame)
+ (frame (sys::the-frame)
+ (sys::frame-up 1 frame mode)))
+ ((eq frame last) (nreverse frames))
+ (unless (boring-frame-p frame)
+ (push frame frames)))))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let* (;;(sys::*break-count* (1+ sys::*break-count*))
+ ;;(sys::*driver* debugger-loop-fn)
+ ;;(sys::*fasoutput-stream* nil)
+ (*sldb-backtrace*
+ (let* ((f (sys::the-frame))
+ (bt (sldb-backtrace))
+ (rest (member f bt)))
+ (if rest (nthcdr 8 rest) bt))))
+ (funcall debugger-loop-fn)))
+
+(defun nth-frame (index)
+ (nth index *sldb-backtrace*))
+
+(defun boring-frame-p (frame)
+ (member (frame-type frame) '(stack-value bind-var bind-env
+ compiled-tagbody compiled-block)))
+
+(defun frame-to-string (frame)
+ (with-output-to-string (s)
+ (sys::describe-frame s frame)))
+
+(defun frame-type (frame)
+ ;; FIXME: should bind *print-length* etc. to small values.
+ (frame-string-type (frame-to-string frame)))
+
+;; FIXME: they changed the layout in 2.44 and not all patterns have
+;; been updated.
+(defvar *frame-prefixes*
+ '(("\\[[0-9]\\+\\] frame binding variables" bind-var)
+ ("<1> #<compiled-function" compiled-fun)
+ ("<1> #<system-function" sys-fun)
+ ("<1> #<special-operator" special-op)
+ ("EVAL frame" eval)
+ ("APPLY frame" apply)
+ ("\\[[0-9]\\+\\] compiled tagbody frame" compiled-tagbody)
+ ("\\[[0-9]\\+\\] compiled block frame" compiled-block)
+ ("block frame" block)
+ ("nested block frame" block)
+ ("tagbody frame" tagbody)
+ ("nested tagbody frame" tagbody)
+ ("catch frame" catch)
+ ("handler frame" handler)
+ ("unwind-protect frame" unwind-protect)
+ ("driver frame" driver)
+ ("\\[[0-9]\\+\\] frame binding environments" bind-env)
+ ("CALLBACK frame" callback)
+ ("- " stack-value)
+ ("<1> " fun)
+ ("<2> " 2nd-frame)
+ ))
+
+(defun frame-string-type (string)
+ (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
+ *frame-prefixes*)))
+
+(defimplementation compute-backtrace (start end)
+ (let* ((bt *sldb-backtrace*)
+ (len (length bt)))
+ (loop for f in (subseq bt start (min (or end len) len))
+ collect f)))
+
+(defimplementation print-frame (frame stream)
+ (let* ((str (frame-to-string frame)))
+ (write-string (extract-frame-line str)
+ stream)))
+
+(defun extract-frame-line (frame-string)
+ (let ((s frame-string))
+ (trim-whitespace
+ (case (frame-string-type s)
+ ((eval special-op)
+ (string-match "EVAL frame .*for form \\(.*\\)" s 1))
+ (apply
+ (string-match "APPLY frame for call \\(.*\\)" s 1))
+ ((compiled-fun sys-fun fun)
+ (extract-function-name s))
+ (t s)))))
+
+(defun extract-function-name (string)
+ (let ((1st (car (split-frame-string string))))
+ (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
+ 1st
+ 1)
+ (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
+ 1st)))
+
+(defun split-frame-string (string)
+ (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
+ (mapcar #'car *frame-prefixes*))))
+ (loop for pos = 0 then (1+ (regexp:match-start match))
+ for match = (regexp:match rx string :start pos)
+ if match collect (subseq string pos (regexp:match-start match))
+ else collect (subseq string pos)
+ while match)))
+
+(defun string-match (pattern string n)
+ (let* ((match (nth-value n (regexp:match pattern string))))
+ (if match (regexp:match-string string match))))
+
+(defimplementation eval-in-frame (form frame-number)
+ (sys::eval-at (nth-frame frame-number) form))
+
+(defimplementation frame-locals (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (loop for i below (%frame-count-vars frame)
+ collect (list :name (%frame-var-name frame i)
+ :value (%frame-var-value frame i)
+ :id 0))))
+
+(defimplementation frame-var-value (frame var)
+ (%frame-var-value (nth-frame frame) var))
+
+;;; Interpreter-Variablen-Environment has the shape
+;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
+
+(defun %frame-count-vars (frame)
+ (cond ((sys::eval-frame-p frame)
+ (do ((venv (frame-venv frame) (next-venv venv))
+ (count 0 (+ count (/ (1- (length venv)) 2))))
+ ((not venv) count)))
+ ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
+ (length (%parse-stack-values frame)))
+ (t 0)))
+
+(defun %frame-var-name (frame i)
+ (cond ((sys::eval-frame-p frame)
+ (nth-value 0 (venv-ref (frame-venv frame) i)))
+ (t (format nil "~D" i))))
+
+(defun %frame-var-value (frame i)
+ (cond ((sys::eval-frame-p frame)
+ (let ((name (venv-ref (frame-venv frame) i)))
+ (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
+ (if c
+ (format-sldb-condition c)
+ v))))
+ ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
+ (let ((str (nth i (%parse-stack-values frame))))
+ (trim-whitespace (subseq str 2))))
+ (t (break "Not implemented"))))
+
+(defun frame-venv (frame)
+ (let ((env (sys::eval-at frame '(sys::the-environment))))
+ (svref env 0)))
+
+(defun next-venv (venv) (svref venv (1- (length venv))))
+
+(defun venv-ref (env i)
+ "Reference the Ith binding in ENV.
+Return two values: NAME and VALUE"
+ (let ((idx (* i 2)))
+ (if (< idx (1- (length env)))
+ (values (svref env idx) (svref env (1+ idx)))
+ (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
+
+(defun %parse-stack-values (frame)
+ (labels ((next (fp) (sys::frame-down 1 fp 1))
+ (parse (fp accu)
+ (let ((str (frame-to-string fp)))
+ (cond ((is-prefix-p "- " str)
+ (parse (next fp) (cons str accu)))
+ ((is-prefix-p "<1> " str)
+ ;;(when (eq (frame-type frame) 'compiled-fun)
+ ;; (pop accu))
+ (dolist (str (cdr (split-frame-string str)))
+ (when (is-prefix-p "- " str)
+ (push str accu)))
+ (nreverse accu))
+ (t (parse (next fp) accu))))))
+ (parse (next frame) '())))
+
+(defun is-prefix-p (regexp string)
+ (if (regexp:match (concatenate 'string "^" regexp) string) t))
+
+(defimplementation return-from-frame (index form)
+ (sys::return-from-eval-frame (nth-frame index) form))
+
+(defimplementation restart-frame (index)
+ (sys::redo-eval-frame (nth-frame index)))
+
+(defimplementation frame-source-location (index)
+ `(:error
+ ,(format nil "frame-source-location not implemented. (frame: ~A)"
+ (nth-frame index))))
+
+;;;; Profiling
+
+(defimplementation profile (fname)
+ (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro
+
+(defimplementation profiled-functions ()
+ swank-monitor:*monitored-functions*)
+
+(defimplementation unprofile (fname)
+ (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro
+
+(defimplementation unprofile-all ()
+ (swank-monitor:unmonitor))
+
+(defimplementation profile-report ()
+ (swank-monitor:report-monitoring))
+
+(defimplementation profile-reset ()
+ (swank-monitor:reset-all-monitoring))
+
+(defimplementation profile-package (package callers-p methods)
+ (declare (ignore callers-p methods))
+ (swank-monitor:monitor-all package))
+
+;;;; Handle compiler conditions (find out location of error etc.)
+
+(defmacro compile-file-frobbing-notes ((&rest args) &body body)
+ "Pass ARGS to COMPILE-FILE, send the compiler notes to
+*STANDARD-INPUT* and frob them in BODY."
+ `(let ((*error-output* (make-string-output-stream))
+ (*compile-verbose* t))
+ (multiple-value-prog1
+ (compile-file ,@args)
+ (handler-case
+ (with-input-from-string
+ (*standard-input* (get-output-stream-string *error-output*))
+ ,@body)
+ (sys::simple-end-of-file () nil)))))
+
+(defvar *orig-c-warn* (symbol-function 'system::c-warn))
+(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
+(defvar *orig-c-error* (symbol-function 'system::c-error))
+(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
+
+(defmacro dynamic-flet (names-functions &body body)
+ "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
+Execute BODY with NAME's function slot set to FUNCTION."
+ `(ext:letf* ,(loop for (name function) in names-functions
+ collect `((symbol-function ',name) ,function))
+ ,@body))
+
+(defvar *buffer-name* nil)
+(defvar *buffer-offset*)
+
+(defun compiler-note-location ()
+ "Return the current compiler location."
+ (let ((lineno1 sys::*compile-file-lineno1*)
+ (lineno2 sys::*compile-file-lineno2*)
+ (file sys::*compile-file-truename*))
+ (cond ((and file lineno1 lineno2)
+ (make-location (list ':file (namestring file))
+ (list ':line lineno1)))
+ (*buffer-name*
+ (make-location (list ':buffer *buffer-name*)
+ (list ':offset *buffer-offset* 0)))
+ (t
+ (list :error "No error location available")))))
+
+(defun signal-compiler-warning (cstring args severity orig-fn)
+ (signal 'compiler-condition
+ :severity severity
+ :message (apply #'format nil cstring args)
+ :location (compiler-note-location))
+ (apply orig-fn cstring args))
+
+(defun c-warn (cstring &rest args)
+ (signal-compiler-warning cstring args :warning *orig-c-warn*))
+
+(defun c-style-warn (cstring &rest args)
+ (dynamic-flet ((sys::c-warn *orig-c-warn*))
+ (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
+
+(defun c-error (&rest args)
+ (signal 'compiler-condition
+ :severity :error
+ :message (apply #'format nil
+ (if (= (length args) 3)
+ (cdr args)
+ args))
+ :location (compiler-note-location))
+ (apply *orig-c-error* args))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((warning #'handle-notification-condition))
+ (dynamic-flet ((system::c-warn #'c-warn)
+ (system::c-style-warn #'c-style-warn)
+ (system::c-error #'c-error))
+ (funcall function))))
+
+(defun handle-notification-condition (condition)
+ "Handle a condition caused by a compiler warning."
+ (signal 'compiler-condition
+ :original-condition condition
+ :severity :warning
+ :message (princ-to-string condition)
+ :location (compiler-note-location)))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (with-compilation-unit ()
+ (multiple-value-bind (fasl-file warningsp failurep)
+ (compile-file input-file
+ :output-file output-file
+ :external-format external-format)
+ (values fasl-file warningsp
+ (or failurep
+ (and load-p
+ (not (load fasl-file)))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore filename policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-offset* position))
+ (funcall (compile nil (read-from-string
+ (format nil "(~S () ~A)" 'lambda string))))
+ t)))
+
+;;;; Portable XREF from the CMU AI repository.
+
+(setq pxref::*handle-package-forms* '(cl:in-package))
+
+(defmacro defxref (name function)
+ `(defimplementation ,name (name)
+ (xref-results (,function name))))
+
+(defxref who-calls pxref:list-callers)
+(defxref who-references pxref:list-readers)
+(defxref who-binds pxref:list-setters)
+(defxref who-sets pxref:list-setters)
+(defxref list-callers pxref:list-callers)
+(defxref list-callees pxref:list-callees)
+
+(defun xref-results (symbols)
+ (let ((xrefs '()))
+ (dolist (symbol symbols)
+ (push (fspec-location symbol symbol) xrefs))
+ xrefs))
+
+(when (find-package :swank-loader)
+ (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
+ (lambda ()
+ (let ((home (user-homedir-pathname)))
+ (and (ext:probe-directory home)
+ (probe-file (format nil "~A/.swank.lisp"
+ (namestring (truename home)))))))))
+
+;;; Don't set *debugger-hook* to nil on break.
+(ext:without-package-lock ()
+ (defun break (&optional (format-string "Break") &rest args)
+ (if (not sys::*use-clcs*)
+ (progn
+ (terpri *error-output*)
+ (apply #'format *error-output*
+ (concatenate 'string "*** - " format-string)
+ args)
+ (funcall ext:*break-driver* t))
+ (let ((condition
+ (make-condition 'simple-condition
+ :format-control format-string
+ :format-arguments args))
+ ;;(*debugger-hook* nil)
+ ;; Issue 91
+ )
+ (ext:with-restarts
+ ((continue
+ :report (lambda (stream)
+ (format stream (sys::text "Return from ~S loop")
+ 'break))
+ ()))
+ (with-condition-restarts condition (list (find-restart 'continue))
+ (invoke-debugger condition)))))
+ nil))
+
+;;;; Inspecting
+
+(defmethod emacs-inspect ((o t))
+ (let* ((*print-array* nil) (*print-pretty* t)
+ (*print-circle* t) (*print-escape* t)
+ (*print-lines* custom:*inspect-print-lines*)
+ (*print-level* custom:*inspect-print-level*)
+ (*print-length* custom:*inspect-print-length*)
+ (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
+ (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
+ (*package* tmp-pack)
+ (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
+ (let ((inspection (sys::inspect-backend o)))
+ (append (list
+ (format nil "~S~% ~A~{~%~A~}~%" o
+ (sys::insp-title inspection)
+ (sys::insp-blurb inspection)))
+ (loop with count = (sys::insp-num-slots inspection)
+ for i below count
+ append (multiple-value-bind (value name)
+ (funcall (sys::insp-nth-slot inspection)
+ i)
+ `((:value ,name) " = " (:value ,value)
+ (:newline))))))))
+
+(defimplementation quit-lisp ()
+ #+lisp=cl (ext:quit)
+ #-lisp=cl (lisp:quit))
+
+
+(defimplementation preferred-communication-style ()
+ nil)
+
+;;; FIXME
+;;;
+;;; Clisp 2.48 added experimental support for threads. Basically, you
+;;; can use :SPAWN now, BUT:
+;;;
+;;; - there are problems with GC, and threads stuffed into weak
+;;; hash-tables as is the case for *THREAD-PLIST-TABLE*.
+;;;
+;;; See test case at
+;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429
+;;;
+;;; Even though said to be fixed, it's not:
+;;;
+;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443
+;;;
+;;; - The DYNAMIC-FLET above is an implementation technique that's
+;;; probably not sustainable in light of threads. This got to be
+;;; rewritten.
+;;;
+;;; TCR (2009-07-30)
+
+#+#.(cl:if (cl:find-package "MP") '(:and) '(:or))
+(progn
+ (defimplementation spawn (fn &key name)
+ (mp:make-thread fn :name name))
+
+ (defvar *thread-plist-table-lock*
+ (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK"))
+
+ (defvar *thread-plist-table* (make-hash-table :weak :key)
+ "A hashtable mapping threads to a plist.")
+
+ (defvar *thread-id-counter* 0)
+
+ (defimplementation thread-id (thread)
+ (mp:with-mutex-lock (*thread-plist-table-lock*)
+ (or (getf (gethash thread *thread-plist-table*) 'thread-id)
+ (setf (getf (gethash thread *thread-plist-table*) 'thread-id)
+ (incf *thread-id-counter*)))))
+
+ (defimplementation find-thread (id)
+ (find id (all-threads)
+ :key (lambda (thread)
+ (getf (gethash thread *thread-plist-table*) 'thread-id))))
+
+ (defimplementation thread-name (thread)
+ ;; To guard against returning #<UNBOUND>.
+ (princ-to-string (mp:thread-name thread)))
+
+ (defimplementation thread-status (thread)
+ (if (thread-alive-p thread)
+ "RUNNING"
+ "STOPPED"))
+
+ (defimplementation make-lock (&key name)
+ (mp:make-mutex :name name :recursive-p t))
+
+ (defimplementation call-with-lock-held (lock function)
+ (mp:with-mutex-lock (lock)
+ (funcall function)))
+
+ (defimplementation current-thread ()
+ (mp:current-thread))
+
+ (defimplementation all-threads ()
+ (mp:list-threads))
+
+ (defimplementation interrupt-thread (thread fn)
+ (mp:thread-interrupt thread :function fn))
+
+ (defimplementation kill-thread (thread)
+ (mp:thread-interrupt thread :function t))
+
+ (defimplementation thread-alive-p (thread)
+ (mp:thread-active-p thread))
+
+ (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK"))
+ (defvar *mailboxes* (list))
+
+ (defstruct (mailbox (:conc-name mailbox.))
+ thread
+ (lock (make-lock :name "MAILBOX.LOCK"))
+ (waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE"))
+ (queue '() :type list))
+
+ (defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-mutex-lock (*mailboxes-lock*)
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+ (defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (lock (mailbox.lock mbox)))
+ (mp:with-mutex-lock (lock)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (mp:exemption-broadcast (mailbox.waitqueue mbox)))))
+
+ (defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox (current-thread)))
+ (lock (mailbox.lock mbox)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (mp:with-mutex-lock (lock)
+ (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)))
+ (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2))))))
+
+
+;;;; Weak hashtables
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak :key args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ (apply #'make-hash-table :weak :value args))
+
+(defimplementation save-image (filename &optional restart-function)
+ (let ((args `(,filename
+ ,@(if restart-function
+ `((:init-function ,restart-function))))))
+ (apply #'ext:saveinitmem args)))
diff --git a/vim/bundle/slimv/slime/swank/cmucl.lisp b/vim/bundle/slimv/slime/swank/cmucl.lisp
new file mode 100644
index 0000000..12d4282
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/cmucl.lisp
@@ -0,0 +1,2470 @@
+;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
+;;;
+;;; License: Public Domain
+;;;
+;;;; Introduction
+;;;
+;;; This is the CMUCL implementation of the `swank/backend' package.
+
+(defpackage swank/cmucl
+ (:use cl swank/backend swank/source-path-parser swank/source-file-cache
+ fwrappers))
+
+(in-package swank/cmucl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (let ((min-version #x20c))
+ (assert (>= c:byte-fasl-file-version min-version)
+ () "This file requires CMUCL version ~x or newer" min-version))
+
+ (require 'gray-streams))
+
+
+(import-swank-mop-symbols :pcl '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (documentation slot t))
+
+;;; UTF8
+
+(locally (declare (optimize (ext:inhibit-warnings 3)))
+ ;; Compile and load the utf8 format, if not already loaded.
+ (stream::find-external-format :utf-8))
+
+(defimplementation string-to-utf8 (string)
+ (let ((ef (load-time-value (stream::find-external-format :utf-8) t)))
+ (stream:string-to-octets string :external-format ef)))
+
+(defimplementation utf8-to-string (octets)
+ (let ((ef (load-time-value (stream::find-external-format :utf-8) t)))
+ (stream:octets-to-string octets :external-format ef)))
+
+
+;;;; TCP server
+;;;
+;;; In CMUCL we support all communication styles. By default we use
+;;; `:SIGIO' because it is the most responsive, but it's somewhat
+;;; dangerous: CMUCL is not in general "signal safe", and you don't
+;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and
+;;; `:SPAWN' are reasonable alternatives.
+
+(defimplementation preferred-communication-style ()
+ :sigio)
+
+#-(or darwin mips)
+(defimplementation create-socket (host port &key backlog)
+ (let* ((addr (resolve-hostname host))
+ (addr (if (not (find-symbol "SOCKET-ERROR" :ext))
+ (ext:htonl addr)
+ addr)))
+ (ext:create-inet-listener port :stream :reuse-address t :host addr
+ :backlog (or backlog 5))))
+
+;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix.
+#+(or darwin mips)
+(defimplementation create-socket (host port &key backlog)
+ (declare (ignore host))
+ (ext:create-inet-listener port :stream :reuse-address t))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
+
+(defimplementation close-socket (socket)
+ (let ((fd (socket-fd socket)))
+ (sys:invalidate-descriptor fd)
+ (ext:close-socket fd)))
+
+(defimplementation accept-connection (socket &key
+ external-format buffering timeout)
+ (declare (ignore timeout))
+ (make-socket-io-stream (ext:accept-tcp-connection socket)
+ (ecase buffering
+ ((t) :full)
+ (:line :line)
+ ((nil) :none))
+ external-format))
+
+;;;;; Sockets
+
+(defimplementation socket-fd (socket)
+ "Return the filedescriptor for the socket represented by SOCKET."
+ (etypecase socket
+ (fixnum socket)
+ (sys:fd-stream (sys:fd-stream-fd socket))))
+
+(defun resolve-hostname (hostname)
+ "Return the IP address of HOSTNAME as an integer (in host byte-order)."
+ (let ((hostent (ext:lookup-host-entry hostname)))
+ (car (ext:host-entry-addr-list hostent))))
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1 "iso-latin-1-unix")
+ #+unicode
+ (:utf-8 "utf-8-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defun make-socket-io-stream (fd buffering external-format)
+ "Create a new input/output fd-stream for FD."
+ (cond (external-format
+ (sys:make-fd-stream fd :input t :output t
+ :element-type 'character
+ :buffering buffering
+ :external-format external-format))
+ (t
+ (sys:make-fd-stream fd :input t :output t
+ :element-type '(unsigned-byte 8)
+ :buffering buffering))))
+
+(defimplementation make-fd-stream (fd external-format)
+ (make-socket-io-stream fd :full external-format))
+
+(defimplementation dup (fd)
+ (multiple-value-bind (clone error) (unix:unix-dup fd)
+ (unless clone (error "dup failed: ~a" (unix:get-unix-error-msg error)))
+ clone))
+
+(defimplementation command-line-args ()
+ ext:*command-line-strings*)
+
+(defimplementation exec-image (image-file args)
+ (multiple-value-bind (ok error)
+ (unix:unix-execve (car (command-line-args))
+ (list* (car (command-line-args))
+ "-core" image-file
+ "-noinit"
+ args))
+ (error "~a" (unix:get-unix-error-msg error))
+ ok))
+
+;;;;; Signal-driven I/O
+
+(defimplementation install-sigint-handler (function)
+ (sys:enable-interrupt :sigint (lambda (signal code scp)
+ (declare (ignore signal code scp))
+ (funcall function))))
+
+(defvar *sigio-handlers* '()
+ "List of (key . function) pairs.
+All functions are called on SIGIO, and the key is used for removing
+specific functions.")
+
+(defun reset-sigio-handlers () (setq *sigio-handlers* '()))
+;; All file handlers are invalid afer reload.
+(pushnew 'reset-sigio-handlers ext:*after-save-initializations*)
+
+(defun set-sigio-handler ()
+ (sys:enable-interrupt :sigio (lambda (signal code scp)
+ (sigio-handler signal code scp))))
+
+(defun sigio-handler (signal code scp)
+ (declare (ignore signal code scp))
+ (mapc #'funcall (mapcar #'cdr *sigio-handlers*)))
+
+(defun fcntl (fd command arg)
+ "fcntl(2) - manipulate a file descriptor."
+ (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
+ (cond (ok)
+ (t (error "fcntl: ~A" (unix:get-unix-error-msg error))))))
+
+(defimplementation add-sigio-handler (socket fn)
+ (set-sigio-handler)
+ (let ((fd (socket-fd socket)))
+ (fcntl fd unix:f-setown (unix:unix-getpid))
+ (let ((old-flags (fcntl fd unix:f-getfl 0)))
+ (fcntl fd unix:f-setfl (logior old-flags unix:fasync)))
+ (assert (not (assoc fd *sigio-handlers*)))
+ (push (cons fd fn) *sigio-handlers*)))
+
+(defimplementation remove-sigio-handlers (socket)
+ (let ((fd (socket-fd socket)))
+ (when (assoc fd *sigio-handlers*)
+ (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
+ (let ((old-flags (fcntl fd unix:f-getfl 0)))
+ (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync)))
+ (sys:invalidate-descriptor fd))
+ (assert (not (assoc fd *sigio-handlers*)))
+ (when (null *sigio-handlers*)
+ (sys:default-interrupt :sigio))))
+
+;;;;; SERVE-EVENT
+
+(defimplementation add-fd-handler (socket fn)
+ (let ((fd (socket-fd socket)))
+ (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn)))))
+
+(defimplementation remove-fd-handlers (socket)
+ (sys:invalidate-descriptor (socket-fd socket)))
+
+(defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (let ((ready (remove-if-not #'listen streams)))
+ (when ready (return ready)))
+ (when timeout (return nil))
+ (multiple-value-bind (in out) (make-pipe)
+ (let* ((f (constantly t))
+ (handlers (loop for s in (cons in (mapcar #'to-fd-stream streams))
+ collect (add-one-shot-handler s f))))
+ (unwind-protect
+ (let ((*interrupt-queued-handler* (lambda ()
+ (write-char #\! out))))
+ (when (check-slime-interrupts) (return :interrupt))
+ (sys:serve-event))
+ (mapc #'sys:remove-fd-handler handlers)
+ (close in)
+ (close out))))))
+
+(defun to-fd-stream (stream)
+ (etypecase stream
+ (sys:fd-stream stream)
+ (synonym-stream
+ (to-fd-stream
+ (symbol-value (synonym-stream-symbol stream))))
+ (two-way-stream
+ (to-fd-stream (two-way-stream-input-stream stream)))))
+
+(defun add-one-shot-handler (stream function)
+ (let (handler)
+ (setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input
+ (lambda (fd)
+ (declare (ignore fd))
+ (sys:remove-fd-handler handler)
+ (funcall function stream))))))
+
+(defun make-pipe ()
+ (multiple-value-bind (in out) (unix:unix-pipe)
+ (values (sys:make-fd-stream in :input t :buffering :none)
+ (sys:make-fd-stream out :output t :buffering :none))))
+
+
+;;;; Stream handling
+
+(defimplementation gray-package-name ()
+ "EXT")
+
+
+;;;; Compilation Commands
+
+(defvar *previous-compiler-condition* nil
+ "Used to detect duplicates.")
+
+(defvar *previous-context* nil
+ "Previous compiler error context.")
+
+(defvar *buffer-name* nil
+ "The name of the Emacs buffer we are compiling from.
+NIL if we aren't compiling from a buffer.")
+
+(defvar *buffer-start-position* nil)
+(defvar *buffer-substring* nil)
+
+(defimplementation call-with-compilation-hooks (function)
+ (let ((*previous-compiler-condition* nil)
+ (*previous-context* nil)
+ (*print-readably* nil))
+ (handler-bind ((c::compiler-error #'handle-notification-condition)
+ (c::style-warning #'handle-notification-condition)
+ (c::warning #'handle-notification-condition))
+ (funcall function))))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (clear-xref-info input-file)
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (ext:*ignore-extra-close-parentheses* nil))
+ (multiple-value-bind (output-file warnings-p failure-p)
+ (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)))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore filename policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-substring* string)
+ (source-info (list :emacs-buffer buffer
+ :emacs-buffer-offset position
+ :emacs-buffer-string string)))
+ (with-input-from-string (stream string)
+ (let ((failurep (ext:compile-from-stream stream :source-info
+ source-info)))
+ (not failurep))))))
+
+
+;;;;; Trapping notes
+;;;
+;;; We intercept conditions from the compiler and resignal them as
+;;; `SWANK:COMPILER-CONDITION's.
+
+(defun handle-notification-condition (condition)
+ "Handle a condition caused by a compiler warning."
+ (unless (eq condition *previous-compiler-condition*)
+ (let ((context (c::find-error-context nil)))
+ (setq *previous-compiler-condition* condition)
+ (setq *previous-context* context)
+ (signal-compiler-condition condition context))))
+
+(defun signal-compiler-condition (condition context)
+ (signal 'compiler-condition
+ :original-condition condition
+ :severity (severity-for-emacs condition)
+ :message (compiler-condition-message condition)
+ :source-context (compiler-error-context context)
+ :location (if (read-error-p condition)
+ (read-error-location condition)
+ (compiler-note-location context))))
+
+(defun severity-for-emacs (condition)
+ "Return the severity of CONDITION."
+ (etypecase condition
+ ((satisfies read-error-p) :read-error)
+ (c::compiler-error :error)
+ (c::style-warning :note)
+ (c::warning :warning)))
+
+(defun read-error-p (condition)
+ (eq (type-of condition) 'c::compiler-read-error))
+
+(defun compiler-condition-message (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."
+ (princ-to-string condition))
+
+(defun compiler-error-context (error-context)
+ "Describe context information for Emacs."
+ (declare (type (or c::compiler-error-context null) error-context))
+ (multiple-value-bind (enclosing source)
+ (if error-context
+ (values (c::compiler-error-context-enclosing-source error-context)
+ (c::compiler-error-context-source error-context)))
+ (if (or enclosing source)
+ (format nil "~@[--> ~{~<~%--> ~1:;~A ~>~}~%~]~
+ ~@[==>~{~&~A~}~]"
+ enclosing source))))
+
+(defun read-error-location (condition)
+ (let* ((finfo (car (c::source-info-current-file c::*source-info*)))
+ (file (c::file-info-name finfo))
+ (pos (c::compiler-read-error-position condition)))
+ (cond ((and (eq file :stream) *buffer-name*)
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* pos)))
+ ((and (pathnamep file) (not *buffer-name*))
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ pos))))
+ (t (break)))))
+
+(defun compiler-note-location (context)
+ "Derive the location of a complier message from its context.
+Return a `location' record, or (:error REASON) on failure."
+ (if (null context)
+ (note-error-location)
+ (with-struct (c::compiler-error-context- file-name
+ original-source
+ original-source-path) context
+ (or (locate-compiler-note file-name original-source
+ (reverse original-source-path))
+ (note-error-location)))))
+
+(defun note-error-location ()
+ "Pseudo-location for notes that can't be located."
+ (cond (*compile-file-truename*
+ (make-location (list :file (unix-truename *compile-file-truename*))
+ (list :eof)))
+ (*buffer-name*
+ (make-location (list :buffer *buffer-name*)
+ (list :position *buffer-start-position*)))
+ (t (list :error "No error location available."))))
+
+(defun locate-compiler-note (file source source-path)
+ (cond ((and (eq file :stream) *buffer-name*)
+ ;; Compiling from a buffer
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position*
+ (source-path-string-position
+ source-path *buffer-substring*))))
+ ((and (pathnamep file) (null *buffer-name*))
+ ;; Compiling from a file
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ (source-path-file-position
+ source-path file)))))
+ ((and (eq file :lisp) (stringp source))
+ ;; No location known, but we have the source form.
+ ;; XXX How is this case triggered? -luke (16/May/2004)
+ ;; This can happen if the compiler needs to expand a macro
+ ;; but the macro-expander is not yet compiled. Calling the
+ ;; (interpreted) macro-expander triggers IR1 conversion of
+ ;; the lambda expression for the expander and invokes the
+ ;; compiler recursively.
+ (make-location (list :source-form source)
+ (list :position 1)))))
+
+(defun unix-truename (pathname)
+ (ext:unix-namestring (truename pathname)))
+
+
+;;;; XREF
+;;;
+;;; Cross-reference support is based on the standard CMUCL `XREF'
+;;; package. This package has some caveats: XREF information is
+;;; recorded during compilation and not preserved in fasl files, and
+;;; XREF recording is disabled by default. Redefining functions can
+;;; also cause duplicate references to accumulate, but
+;;; `swank-compile-file' will automatically clear out any old records
+;;; from the same filename.
+;;;
+;;; To enable XREF recording, set `c:*record-xref-info*' to true. To
+;;; clear out the XREF database call `xref:init-xref-database'.
+
+(defmacro defxref (name function)
+ `(defimplementation ,name (name)
+ (xref-results (,function name))))
+
+(defxref who-calls xref:who-calls)
+(defxref who-references xref:who-references)
+(defxref who-binds xref:who-binds)
+(defxref who-sets xref:who-sets)
+
+;;; More types of XREF information were added since 18e:
+;;;
+
+(defxref who-macroexpands xref:who-macroexpands)
+;; XXX
+(defimplementation who-specializes (symbol)
+ (let* ((methods (xref::who-specializes (find-class symbol)))
+ (locations (mapcar #'method-location methods)))
+ (mapcar #'list methods locations)))
+
+(defun xref-results (contexts)
+ (mapcar (lambda (xref)
+ (list (xref:xref-context-name xref)
+ (resolve-xref-location xref)))
+ contexts))
+
+(defun resolve-xref-location (xref)
+ (let ((name (xref:xref-context-name xref))
+ (file (xref:xref-context-file xref))
+ (source-path (xref:xref-context-source-path xref)))
+ (cond ((and file source-path)
+ (let ((position (source-path-file-position source-path file)))
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ position)))))
+ (file
+ (make-location (list :file (unix-truename file))
+ (list :function-name (string name))))
+ (t
+ `(:error ,(format nil "Unknown source location: ~S ~S ~S "
+ name file source-path))))))
+
+(defun clear-xref-info (namestring)
+ "Clear XREF notes pertaining to NAMESTRING.
+This is a workaround for a CMUCL bug: XREF records are cumulative."
+ (when c:*record-xref-info*
+ (let ((filename (truename namestring)))
+ (dolist (db (list xref::*who-calls*
+ xref::*who-is-called*
+ xref::*who-macroexpands*
+ xref::*who-references*
+ xref::*who-binds*
+ xref::*who-sets*))
+ (maphash (lambda (target contexts)
+ ;; XXX update during traversal?
+ (setf (gethash target db)
+ (delete filename contexts
+ :key #'xref:xref-context-file
+ :test #'equalp)))
+ db)))))
+
+
+;;;; Find callers and callees
+;;;
+;;; Find callers and callees by looking at the constant pool of
+;;; compiled code objects. We assume every fdefn object in the
+;;; constant pool corresponds to a call to that function. A better
+;;; strategy would be to use the disassembler to find actual
+;;; call-sites.
+
+(labels ((make-stack () (make-array 100 :fill-pointer 0 :adjustable t))
+ (map-cpool (code fun)
+ (declare (type kernel:code-component code) (type function fun))
+ (loop for i from vm:code-constants-offset
+ below (kernel:get-header-data code)
+ do (funcall fun (kernel:code-header-ref code i))))
+
+ (callees (fun)
+ (let ((callees (make-stack)))
+ (map-cpool (vm::find-code-object fun)
+ (lambda (o)
+ (when (kernel:fdefn-p o)
+ (vector-push-extend (kernel:fdefn-function o)
+ callees))))
+ (coerce callees 'list)))
+
+ (callers (fun)
+ (declare (function fun))
+ (let ((callers (make-stack)))
+ (ext:gc :full t)
+ ;; scan :dynamic first to avoid the need for even more gcing
+ (dolist (space '(:dynamic :read-only :static))
+ (vm::map-allocated-objects
+ (lambda (obj header size)
+ (declare (type fixnum header) (ignore size))
+ (when (= vm:code-header-type header)
+ (map-cpool obj
+ (lambda (c)
+ (when (and (kernel:fdefn-p c)
+ (eq (kernel:fdefn-function c) fun))
+ (vector-push-extend obj callers))))))
+ space)
+ (ext:gc))
+ (coerce callers 'list)))
+
+ (entry-points (code)
+ (loop for entry = (kernel:%code-entry-points code)
+ then (kernel::%function-next entry)
+ while entry
+ collect entry))
+
+ (guess-main-entry-point (entry-points)
+ (or (find-if (lambda (fun)
+ (ext:valid-function-name-p
+ (kernel:%function-name fun)))
+ entry-points)
+ (car entry-points)))
+
+ (fun-dspec (fun)
+ (list (kernel:%function-name fun) (function-location fun)))
+
+ (code-dspec (code)
+ (let ((eps (entry-points code))
+ (di (kernel:%code-debug-info code)))
+ (cond (eps (fun-dspec (guess-main-entry-point eps)))
+ (di (list (c::debug-info-name di)
+ (debug-info-function-name-location di)))
+ (t (list (princ-to-string code)
+ `(:error "No src-loc available")))))))
+ (declare (inline map-cpool))
+
+ (defimplementation list-callers (symbol)
+ (mapcar #'code-dspec (callers (coerce symbol 'function) )))
+
+ (defimplementation list-callees (symbol)
+ (mapcar #'fun-dspec (callees symbol))))
+
+(defun test-list-callers (count)
+ (let ((funsyms '()))
+ (do-all-symbols (s)
+ (when (and (fboundp s)
+ (functionp (symbol-function s))
+ (not (macro-function s))
+ (not (special-operator-p s)))
+ (push s funsyms)))
+ (let ((len (length funsyms)))
+ (dotimes (i count)
+ (let ((sym (nth (random len) funsyms)))
+ (format t "~s -> ~a~%" sym (mapcar #'car (list-callers sym))))))))
+
+;; (test-list-callers 100)
+
+
+;;;; Resolving source locations
+;;;
+;;; Our mission here is to "resolve" references to code locations into
+;;; actual file/buffer names and character positions. The references
+;;; we work from come out of the compiler's statically-generated debug
+;;; information, such as `code-location''s and `debug-source''s. For
+;;; more details, see the "Debugger Programmer's Interface" section of
+;;; the CMUCL manual.
+;;;
+;;; The first step is usually to find the corresponding "source-path"
+;;; for the location. Once we have the source-path we can pull up the
+;;; source file and `READ' our way through to the right position. The
+;;; main source-code groveling work is done in
+;;; `source-path-parser.lisp'.
+
+(defvar *debug-definition-finding* nil
+ "When true don't handle errors while looking for definitions.
+This is useful when debugging the definition-finding code.")
+
+(defmacro safe-definition-finding (&body body)
+ "Execute BODY and return the source-location it returns.
+If an error occurs and `*debug-definition-finding*' is false, then
+return an error pseudo-location.
+
+The second return value is NIL if no error occurs, otherwise it is the
+condition object."
+ `(flet ((body () ,@body))
+ (if *debug-definition-finding*
+ (body)
+ (handler-case (values (progn ,@body) nil)
+ (error (c) (values `(:error ,(trim-whitespace (princ-to-string c)))
+ c))))))
+
+(defun trim-whitespace (string)
+ (string-trim #(#\newline #\space #\tab) string))
+
+(defun code-location-source-location (code-location)
+ "Safe wrapper around `code-location-from-source-location'."
+ (safe-definition-finding
+ (source-location-from-code-location code-location)))
+
+(defun source-location-from-code-location (code-location)
+ "Return the source location for CODE-LOCATION."
+ (let ((debug-fun (di:code-location-debug-function code-location)))
+ (when (di::bogus-debug-function-p debug-fun)
+ ;; Those lousy cheapskates! They've put in a bogus debug source
+ ;; because the code was compiled at a low debug setting.
+ (error "Bogus debug function: ~A" debug-fun)))
+ (let* ((debug-source (di:code-location-debug-source code-location))
+ (from (di:debug-source-from debug-source))
+ (name (di:debug-source-name debug-source)))
+ (ecase from
+ (:file
+ (location-in-file name code-location debug-source))
+ (:stream
+ (location-in-stream code-location debug-source))
+ (:lisp
+ ;; The location comes from a form passed to `compile'.
+ ;; The best we can do is return the form itself for printing.
+ (make-location
+ (list :source-form (with-output-to-string (*standard-output*)
+ (debug::print-code-location-source-form
+ code-location 100 t)))
+ (list :position 1))))))
+
+(defun location-in-file (filename code-location debug-source)
+ "Resolve the source location for CODE-LOCATION in FILENAME."
+ (let* ((code-date (di:debug-source-created debug-source))
+ (root-number (di:debug-source-root-number debug-source))
+ (source-code (get-source-code filename code-date)))
+ (with-input-from-string (s source-code)
+ (make-location (list :file (unix-truename filename))
+ (list :position (1+ (code-location-stream-position
+ code-location s root-number)))
+ `(:snippet ,(read-snippet s))))))
+
+(defun location-in-stream (code-location debug-source)
+ "Resolve the source location for a CODE-LOCATION from a stream.
+This only succeeds if the code was compiled from an Emacs buffer."
+ (unless (debug-source-info-from-emacs-buffer-p debug-source)
+ (error "The code is compiled from a non-SLIME stream."))
+ (let* ((info (c::debug-source-info debug-source))
+ (string (getf info :emacs-buffer-string))
+ (position (code-location-string-offset
+ code-location
+ string)))
+ (make-location
+ (list :buffer (getf info :emacs-buffer))
+ (list :offset (getf info :emacs-buffer-offset) position)
+ (list :snippet (with-input-from-string (s string)
+ (file-position s position)
+ (read-snippet s))))))
+
+;;;;; Function-name locations
+;;;
+(defun debug-info-function-name-location (debug-info)
+ "Return a function-name source-location for DEBUG-INFO.
+Function-name source-locations are a fallback for when precise
+positions aren't available."
+ (with-struct (c::debug-info- (fname name) source) debug-info
+ (with-struct (c::debug-source- info from name) (car source)
+ (ecase from
+ (:file
+ (make-location (list :file (namestring (truename name)))
+ (list :function-name (string fname))))
+ (:stream
+ (assert (debug-source-info-from-emacs-buffer-p (car source)))
+ (make-location (list :buffer (getf info :emacs-buffer))
+ (list :function-name (string fname))))
+ (:lisp
+ (make-location (list :source-form (princ-to-string (aref name 0)))
+ (list :position 1)))))))
+
+(defun debug-source-info-from-emacs-buffer-p (debug-source)
+ "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location?
+This is true for functions that were compiled directly from buffers."
+ (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
+
+(defun info-from-emacs-buffer-p (info)
+ (and info
+ (consp info)
+ (eq :emacs-buffer (car info))))
+
+
+;;;;; Groveling source-code for positions
+
+(defun code-location-stream-position (code-location stream root)
+ "Return the byte offset of CODE-LOCATION in STREAM. Extract the
+toplevel-form-number and form-number from CODE-LOCATION and use that
+to find the position of the corresponding form.
+
+Finish with STREAM positioned at the start of the code location."
+ (let* ((location (debug::maybe-block-start-location code-location))
+ (tlf-offset (- (di:code-location-top-level-form-offset location)
+ root))
+ (form-number (di:code-location-form-number location)))
+ (let ((pos (form-number-stream-position tlf-offset form-number stream)))
+ (file-position stream pos)
+ pos)))
+
+(defun form-number-stream-position (tlf-number form-number stream)
+ "Return the starting character position of a form in STREAM.
+TLF-NUMBER is the top-level-form number.
+FORM-NUMBER is an index into a source-path table for the TLF."
+ (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
+ (let* ((path-table (di:form-number-translations tlf 0))
+ (source-path
+ (if (<= (length path-table) form-number) ; source out of sync?
+ (list 0) ; should probably signal a condition
+ (reverse (cdr (aref path-table form-number))))))
+ (source-path-source-position source-path tlf position-map))))
+
+(defun code-location-string-offset (code-location string)
+ "Return the byte offset of CODE-LOCATION in STRING.
+See CODE-LOCATION-STREAM-POSITION."
+ (with-input-from-string (s string)
+ (code-location-stream-position code-location s 0)))
+
+
+;;;; Finding definitions
+
+;;; There are a great many different types of definition for us to
+;;; find. We search for definitions of every kind and return them in a
+;;; list.
+
+(defimplementation find-definitions (name)
+ (append (function-definitions name)
+ (setf-definitions name)
+ (variable-definitions name)
+ (class-definitions name)
+ (type-definitions name)
+ (compiler-macro-definitions name)
+ (source-transform-definitions name)
+ (function-info-definitions name)
+ (ir1-translator-definitions name)
+ (template-definitions name)
+ (primitive-definitions name)
+ (vm-support-routine-definitions name)
+ ))
+
+;;;;; Functions, macros, generic functions, methods
+;;;
+;;; We make extensive use of the compile-time debug information that
+;;; CMUCL records, in particular "debug functions" and "code
+;;; locations." Refer to the "Debugger Programmer's Interface" section
+;;; of the CMUCL manual for more details.
+
+(defun function-definitions (name)
+ "Return definitions for NAME in the \"function namespace\", i.e.,
+regular functions, generic functions, methods and macros.
+NAME can any valid function name (e.g, (setf car))."
+ (let ((macro? (and (symbolp name) (macro-function name)))
+ (function? (and (ext:valid-function-name-p name)
+ (ext:info :function :definition name)
+ (if (symbolp name) (fboundp name) t))))
+ (cond (macro?
+ (list `((defmacro ,name)
+ ,(function-location (macro-function name)))))
+ (function?
+ (let ((function (fdefinition name)))
+ (if (genericp function)
+ (gf-definitions name function)
+ (list (list `(function ,name)
+ (function-location function)))))))))
+
+;;;;;; Ordinary (non-generic/macro/special) functions
+;;;
+;;; First we test if FUNCTION is a closure created by defstruct, and
+;;; if so extract the defstruct-description (`dd') from the closure
+;;; and find the constructor for the struct. Defstruct creates a
+;;; defun for the default constructor and we use that as an
+;;; approximation to the source location of the defstruct.
+;;;
+;;; For an ordinary function we return the source location of the
+;;; first code-location we find.
+;;;
+(defun function-location (function)
+ "Return the source location for FUNCTION."
+ (cond ((struct-closure-p function)
+ (struct-closure-location function))
+ ((c::byte-function-or-closure-p function)
+ (byte-function-location function))
+ (t
+ (compiled-function-location function))))
+
+(defun compiled-function-location (function)
+ "Return the location of a regular compiled function."
+ (multiple-value-bind (code-location error)
+ (safe-definition-finding (function-first-code-location function))
+ (cond (error (list :error (princ-to-string error)))
+ (t (code-location-source-location code-location)))))
+
+(defun function-first-code-location (function)
+ "Return the first code-location we can find for FUNCTION."
+ (and (function-has-debug-function-p function)
+ (di:debug-function-start-location
+ (di:function-debug-function function))))
+
+(defun function-has-debug-function-p (function)
+ (di:function-debug-function function))
+
+(defun function-code-object= (closure function)
+ (and (eq (vm::find-code-object closure)
+ (vm::find-code-object function))
+ (not (eq closure function))))
+
+(defun byte-function-location (fun)
+ "Return the location of the byte-compiled function FUN."
+ (etypecase fun
+ ((or c::hairy-byte-function c::simple-byte-function)
+ (let* ((di (kernel:%code-debug-info (c::byte-function-component fun))))
+ (if di
+ (debug-info-function-name-location di)
+ `(:error
+ ,(format nil "Byte-function without debug-info: ~a" fun)))))
+ (c::byte-closure
+ (byte-function-location (c::byte-closure-function fun)))))
+
+;;; Here we deal with structure accessors. Note that `dd' is a
+;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a
+;;; `defstruct''d structure.
+
+(defun struct-closure-p (function)
+ "Is FUNCTION a closure created by defstruct?"
+ (or (function-code-object= function #'kernel::structure-slot-accessor)
+ (function-code-object= function #'kernel::structure-slot-setter)
+ (function-code-object= function #'kernel::%defstruct)))
+
+(defun struct-closure-location (function)
+ "Return the location of the structure that FUNCTION belongs to."
+ (assert (struct-closure-p function))
+ (safe-definition-finding
+ (dd-location (struct-closure-dd function))))
+
+(defun struct-closure-dd (function)
+ "Return the defstruct-definition (dd) of FUNCTION."
+ (assert (= (kernel:get-type function) vm:closure-header-type))
+ (flet ((find-layout (function)
+ (sys:find-if-in-closure
+ (lambda (x)
+ (let ((value (if (di::indirect-value-cell-p x)
+ (c:value-cell-ref x)
+ x)))
+ (when (kernel::layout-p value)
+ (return-from find-layout value))))
+ function)))
+ (kernel:layout-info (find-layout function))))
+
+(defun dd-location (dd)
+ "Return the location of a `defstruct'."
+ (let ((ctor (struct-constructor dd)))
+ (cond (ctor
+ (function-location (coerce ctor 'function)))
+ (t
+ (let ((name (kernel:dd-name dd)))
+ (multiple-value-bind (location foundp)
+ (ext:info :source-location :defvar name)
+ (cond (foundp
+ (resolve-source-location location))
+ (t
+ (error "No location for defstruct: ~S" name)))))))))
+
+(defun struct-constructor (dd)
+ "Return the name of the constructor from a defstruct definition."
+ (let* ((constructor (or (kernel:dd-default-constructor dd)
+ (car (kernel::dd-constructors dd)))))
+ (if (consp constructor) (car constructor) constructor)))
+
+;;;;;; Generic functions and methods
+
+(defun gf-definitions (name function)
+ "Return the definitions of a generic function and its methods."
+ (cons (list `(defgeneric ,name) (gf-location function))
+ (gf-method-definitions function)))
+
+(defun gf-location (gf)
+ "Return the location of the generic function GF."
+ (definition-source-location gf (pcl::generic-function-name gf)))
+
+(defun gf-method-definitions (gf)
+ "Return the locations of all methods of the generic function GF."
+ (mapcar #'method-definition (pcl::generic-function-methods gf)))
+
+(defun method-definition (method)
+ (list (method-dspec method)
+ (method-location method)))
+
+(defun method-dspec (method)
+ "Return a human-readable \"definition specifier\" for METHOD."
+ (let* ((gf (pcl:method-generic-function method))
+ (name (pcl:generic-function-name gf))
+ (specializers (pcl:method-specializers method))
+ (qualifiers (pcl:method-qualifiers method)))
+ `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers))))
+
+(defun method-location (method)
+ (typecase method
+ (pcl::standard-accessor-method
+ (definition-source-location
+ (cond ((pcl::definition-source method)
+ method)
+ (t
+ (pcl::slot-definition-class
+ (pcl::accessor-method-slot-definition method))))
+ (pcl::accessor-method-slot-name method)))
+ (t
+ (function-location (or (pcl::method-fast-function method)
+ (pcl:method-function method))))))
+
+(defun genericp (fn)
+ (typep fn 'generic-function))
+
+;;;;;; Types and classes
+
+(defun type-definitions (name)
+ "Return `deftype' locations for type NAME."
+ (maybe-make-definition (ext:info :type :expander name) 'deftype name))
+
+(defun maybe-make-definition (function kind name)
+ "If FUNCTION is non-nil then return its definition location."
+ (if function
+ (list (list `(,kind ,name) (function-location function)))))
+
+(defun class-definitions (name)
+ "Return the definition locations for the class called NAME."
+ (if (symbolp name)
+ (let ((class (kernel::find-class name nil)))
+ (etypecase class
+ (null '())
+ (kernel::structure-class
+ (list (list `(defstruct ,name) (dd-location (find-dd name)))))
+ #+(or)
+ (conditions::condition-class
+ (list (list `(define-condition ,name)
+ (condition-class-location class))))
+ (kernel::standard-class
+ (list (list `(defclass ,name)
+ (pcl-class-location (find-class name)))))
+ ((or kernel::built-in-class
+ conditions::condition-class
+ kernel:funcallable-structure-class)
+ (list (list `(class ,name) (class-location class))))))))
+
+(defun pcl-class-location (class)
+ "Return the `defclass' location for CLASS."
+ (definition-source-location class (pcl:class-name class)))
+
+;; FIXME: eval used for backward compatibility.
+(defun class-location (class)
+ (declare (type kernel::class class))
+ (let ((name (kernel:%class-name class)))
+ (multiple-value-bind (loc found?)
+ (let ((x (ignore-errors
+ (multiple-value-list
+ (eval `(ext:info :source-location :class ',name))))))
+ (values-list x))
+ (cond (found? (resolve-source-location loc))
+ (`(:error
+ ,(format nil "No location recorded for class: ~S" name)))))))
+
+(defun find-dd (name)
+ "Find the defstruct-definition by the name of its structure-class."
+ (let ((layout (ext:info :type :compiler-layout name)))
+ (if layout
+ (kernel:layout-info layout))))
+
+(defun condition-class-location (class)
+ (let ((slots (conditions::condition-class-slots class))
+ (name (conditions::condition-class-name class)))
+ (cond ((null slots)
+ `(:error ,(format nil "No location info for condition: ~A" name)))
+ (t
+ ;; Find the class via one of its slot-reader methods.
+ (let* ((slot (first slots))
+ (gf (fdefinition
+ (first (conditions::condition-slot-readers slot)))))
+ (method-location
+ (first
+ (pcl:compute-applicable-methods-using-classes
+ gf (list (find-class name))))))))))
+
+(defun make-name-in-file-location (file string)
+ (multiple-value-bind (filename c)
+ (ignore-errors
+ (unix-truename (merge-pathnames (make-pathname :type "lisp")
+ file)))
+ (cond (filename (make-location `(:file ,filename)
+ `(:function-name ,(string string))))
+ (t (list :error (princ-to-string c))))))
+
+(defun source-location-form-numbers (location)
+ (c::decode-form-numbers (c::form-numbers-form-numbers location)))
+
+(defun source-location-tlf-number (location)
+ (nth-value 0 (source-location-form-numbers location)))
+
+(defun source-location-form-number (location)
+ (nth-value 1 (source-location-form-numbers location)))
+
+(defun resolve-file-source-location (location)
+ (let ((filename (c::file-source-location-pathname location))
+ (tlf-number (source-location-tlf-number location))
+ (form-number (source-location-form-number location)))
+ (with-open-file (s filename)
+ (let ((pos (form-number-stream-position tlf-number form-number s)))
+ (make-location `(:file ,(unix-truename filename))
+ `(:position ,(1+ pos)))))))
+
+(defun resolve-stream-source-location (location)
+ (let ((info (c::stream-source-location-user-info location))
+ (tlf-number (source-location-tlf-number location))
+ (form-number (source-location-form-number location)))
+ ;; XXX duplication in frame-source-location
+ (assert (info-from-emacs-buffer-p info))
+ (destructuring-bind (&key emacs-buffer emacs-buffer-string
+ emacs-buffer-offset) info
+ (with-input-from-string (s emacs-buffer-string)
+ (let ((pos (form-number-stream-position tlf-number form-number s)))
+ (make-location `(:buffer ,emacs-buffer)
+ `(:offset ,emacs-buffer-offset ,pos)))))))
+
+;; XXX predicates for 18e backward compatibilty. Remove them when
+;; we're 19a only.
+(defun file-source-location-p (object)
+ (when (fboundp 'c::file-source-location-p)
+ (c::file-source-location-p object)))
+
+(defun stream-source-location-p (object)
+ (when (fboundp 'c::stream-source-location-p)
+ (c::stream-source-location-p object)))
+
+(defun source-location-p (object)
+ (or (file-source-location-p object)
+ (stream-source-location-p object)))
+
+(defun resolve-source-location (location)
+ (etypecase location
+ ((satisfies file-source-location-p)
+ (resolve-file-source-location location))
+ ((satisfies stream-source-location-p)
+ (resolve-stream-source-location location))))
+
+(defun definition-source-location (object name)
+ (let ((source (pcl::definition-source object)))
+ (etypecase source
+ (null
+ `(:error ,(format nil "No source info for: ~A" object)))
+ ((satisfies source-location-p)
+ (resolve-source-location source))
+ (pathname
+ (make-name-in-file-location source name))
+ (cons
+ (destructuring-bind ((dg name) pathname) source
+ (declare (ignore dg))
+ (etypecase pathname
+ (pathname (make-name-in-file-location pathname (string name)))
+ (null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))
+
+(defun setf-definitions (name)
+ (let ((f (or (ext:info :setf :inverse name)
+ (ext:info :setf :expander name)
+ (and (symbolp name)
+ (fboundp `(setf ,name))
+ (fdefinition `(setf ,name))))))
+ (if f
+ `(((setf ,name) ,(function-location (cond ((functionp f) f)
+ ((macro-function f))
+ ((fdefinition f)))))))))
+
+(defun variable-location (symbol)
+ (multiple-value-bind (location foundp)
+ ;; XXX for 18e compatibilty. rewrite this when we drop 18e
+ ;; support.
+ (ignore-errors (eval `(ext:info :source-location :defvar ',symbol)))
+ (if (and foundp location)
+ (resolve-source-location location)
+ `(:error ,(format nil "No source info for variable ~S" symbol)))))
+
+(defun variable-definitions (name)
+ (if (symbolp name)
+ (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
+ (if recorded-p
+ (list (list `(variable ,kind ,name)
+ (variable-location name)))))))
+
+(defun compiler-macro-definitions (symbol)
+ (maybe-make-definition (compiler-macro-function symbol)
+ 'define-compiler-macro
+ symbol))
+
+(defun source-transform-definitions (name)
+ (maybe-make-definition (ext:info :function :source-transform name)
+ 'c:def-source-transform
+ name))
+
+(defun function-info-definitions (name)
+ (let ((info (ext:info :function :info name)))
+ (if info
+ (append (loop for transform in (c::function-info-transforms info)
+ collect (list `(c:deftransform ,name
+ ,(c::type-specifier
+ (c::transform-type transform)))
+ (function-location (c::transform-function
+ transform))))
+ (maybe-make-definition (c::function-info-derive-type info)
+ 'c::derive-type name)
+ (maybe-make-definition (c::function-info-optimizer info)
+ 'c::optimizer name)
+ (maybe-make-definition (c::function-info-ltn-annotate info)
+ 'c::ltn-annotate name)
+ (maybe-make-definition (c::function-info-ir2-convert info)
+ 'c::ir2-convert name)
+ (loop for template in (c::function-info-templates info)
+ collect (list `(,(type-of template)
+ ,(c::template-name template))
+ (function-location
+ (c::vop-info-generator-function
+ template))))))))
+
+(defun ir1-translator-definitions (name)
+ (maybe-make-definition (ext:info :function :ir1-convert name)
+ 'c:def-ir1-translator name))
+
+(defun template-definitions (name)
+ (let* ((templates (c::backend-template-names c::*backend*))
+ (template (gethash name templates)))
+ (etypecase template
+ (null)
+ (c::vop-info
+ (maybe-make-definition (c::vop-info-generator-function template)
+ (type-of template) name)))))
+
+;; for cases like: (%primitive NAME ...)
+(defun primitive-definitions (name)
+ (let ((csym (find-symbol (string name) 'c)))
+ (and csym
+ (not (eq csym name))
+ (template-definitions csym))))
+
+(defun vm-support-routine-definitions (name)
+ (let ((sr (c::backend-support-routines c::*backend*))
+ (name (find-symbol (string name) 'c)))
+ (and name
+ (slot-exists-p sr name)
+ (maybe-make-definition (slot-value sr name)
+ (find-symbol (string 'vm-support-routine) 'c)
+ name))))
+
+
+;;;; Documentation.
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (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)
+ (ext: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)
+ ((genericp (fdefinition symbol)) :generic-function)
+ (t :function))
+ (doc 'function)))
+ (maybe-push
+ :setf (if (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol))
+ (doc 'setf)))
+ (maybe-push
+ :type (if (ext:info type kind symbol)
+ (doc 'type)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ (maybe-push
+ :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
+ (doc 'alien-type)))
+ (maybe-push
+ :alien-struct (if (ext:info alien-type struct symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-union (if (ext:info alien-type union symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-enum (if (ext:info alien-type enum symbol)
+ (doc nil)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (describe (ecase namespace
+ (:variable
+ symbol)
+ ((:function :generic-function)
+ (symbol-function symbol))
+ (:setf
+ (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol)))
+ (:type
+ (kernel:values-specifier-type symbol))
+ (:class
+ (find-class symbol))
+ (:alien-struct
+ (ext:info :alien-type :struct symbol))
+ (:alien-union
+ (ext:info :alien-type :union symbol))
+ (:alien-enum
+ (ext:info :alien-type :enum symbol))
+ (:alien-type
+ (ecase (ext:info :alien-type :kind symbol)
+ (:primitive
+ (let ((alien::*values-type-okay* t))
+ (funcall (ext:info :alien-type :translator symbol)
+ (list symbol))))
+ ((:defined)
+ (ext:info :alien-type :definition symbol))
+ (:unknown :unkown))))))
+
+;;;;; Argument lists
+
+(defimplementation arglist (fun)
+ (etypecase fun
+ (function (function-arglist fun))
+ (symbol (function-arglist (or (macro-function fun)
+ (symbol-function fun))))))
+
+(defun function-arglist (fun)
+ (let ((arglist
+ (cond ((eval:interpreted-function-p fun)
+ (eval:interpreted-function-arglist fun))
+ ((pcl::generic-function-p fun)
+ (pcl:generic-function-lambda-list fun))
+ ((c::byte-function-or-closure-p fun)
+ (byte-code-function-arglist fun))
+ ((kernel:%function-arglist (kernel:%function-self fun))
+ (handler-case (read-arglist fun)
+ (error () :not-available)))
+ ;; this should work both for compiled-debug-function
+ ;; and for interpreted-debug-function
+ (t
+ (handler-case (debug-function-arglist
+ (di::function-debug-function fun))
+ (di:unhandled-condition () :not-available))))))
+ (check-type arglist (or list (member :not-available)))
+ arglist))
+
+(defimplementation function-name (function)
+ (cond ((eval:interpreted-function-p function)
+ (eval:interpreted-function-name function))
+ ((pcl::generic-function-p function)
+ (pcl::generic-function-name function))
+ ((c::byte-function-or-closure-p function)
+ (c::byte-function-name function))
+ (t (kernel:%function-name (kernel:%function-self function)))))
+
+;;; A simple case: the arglist is available as a string that we can
+;;; `read'.
+
+(defun read-arglist (fn)
+ "Parse the arglist-string of the function object FN."
+ (let ((string (kernel:%function-arglist
+ (kernel:%function-self fn)))
+ (package (find-package
+ (c::compiled-debug-info-package
+ (kernel:%code-debug-info
+ (vm::find-code-object fn))))))
+ (with-standard-io-syntax
+ (let ((*package* (or package *package*)))
+ (read-from-string string)))))
+
+;;; A harder case: an approximate arglist is derived from available
+;;; debugging information.
+
+(defun debug-function-arglist (debug-function)
+ "Derive the argument list of DEBUG-FUNCTION from debug info."
+ (let ((args (di::debug-function-lambda-list debug-function))
+ (required '())
+ (optional '())
+ (rest '())
+ (key '()))
+ ;; collect the names of debug-vars
+ (dolist (arg args)
+ (etypecase arg
+ (di::debug-variable
+ (push (di::debug-variable-symbol arg) required))
+ ((member :deleted)
+ (push ':deleted required))
+ (cons
+ (ecase (car arg)
+ (:keyword
+ (push (second arg) key))
+ (:optional
+ (push (debug-variable-symbol-or-deleted (second arg)) optional))
+ (:rest
+ (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
+ ;; intersperse lambda keywords as needed
+ (append (nreverse required)
+ (if optional (cons '&optional (nreverse optional)))
+ (if rest (cons '&rest (nreverse rest)))
+ (if key (cons '&key (nreverse key))))))
+
+(defun debug-variable-symbol-or-deleted (var)
+ (etypecase var
+ (di:debug-variable
+ (di::debug-variable-symbol var))
+ ((member :deleted)
+ '#:deleted)))
+
+(defun symbol-debug-function-arglist (fname)
+ "Return FNAME's debug-function-arglist and %function-arglist.
+A utility for debugging DEBUG-FUNCTION-ARGLIST."
+ (let ((fn (fdefinition fname)))
+ (values (debug-function-arglist (di::function-debug-function fn))
+ (kernel:%function-arglist (kernel:%function-self fn)))))
+
+;;; Deriving arglists for byte-compiled functions:
+;;;
+(defun byte-code-function-arglist (fn)
+ ;; There doesn't seem to be much arglist information around for
+ ;; byte-code functions. Use the arg-count and return something like
+ ;; (arg0 arg1 ...)
+ (etypecase fn
+ (c::simple-byte-function
+ (loop for i from 0 below (c::simple-byte-function-num-args fn)
+ collect (make-arg-symbol i)))
+ (c::hairy-byte-function
+ (hairy-byte-function-arglist fn))
+ (c::byte-closure
+ (byte-code-function-arglist (c::byte-closure-function fn)))))
+
+(defun make-arg-symbol (i)
+ (make-symbol (format nil "~A~D" (string 'arg) i)))
+
+;;; A "hairy" byte-function is one that takes a variable number of
+;;; arguments. `hairy-byte-function' is a type from the bytecode
+;;; interpreter.
+;;;
+(defun hairy-byte-function-arglist (fn)
+ (let ((counter -1))
+ (flet ((next-arg () (make-arg-symbol (incf counter))))
+ (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
+ keywords-p keywords) fn
+ (let ((arglist '())
+ (optional (- max-args min-args)))
+ ;; XXX isn't there a better way to write this?
+ ;; (Looks fine to me. -luke)
+ (dotimes (i min-args)
+ (push (next-arg) arglist))
+ (when (plusp optional)
+ (push '&optional arglist)
+ (dotimes (i optional)
+ (push (next-arg) arglist)))
+ (when rest-arg-p
+ (push '&rest arglist)
+ (push (next-arg) arglist))
+ (when keywords-p
+ (push '&key arglist)
+ (loop for (key _ __) in keywords
+ do (push key arglist))
+ (when (eq keywords-p :allow-others)
+ (push '&allow-other-keys arglist)))
+ (nreverse arglist))))))
+
+
+;;;; Miscellaneous.
+
+(defimplementation macroexpand-all (form &optional env)
+ (walker:macroexpand-all form env))
+
+(defimplementation compiler-macroexpand-1 (form &optional env)
+ (ext:compiler-macroexpand-1 form env))
+
+(defimplementation compiler-macroexpand (form &optional env)
+ (ext:compiler-macroexpand form env))
+
+(defimplementation set-default-directory (directory)
+ (setf (ext:default-directory) (namestring directory))
+ ;; Setting *default-pathname-defaults* to an absolute directory
+ ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
+ (setf *default-pathname-defaults* (pathname (ext:default-directory)))
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (ext:default-directory)))
+
+(defimplementation getpid ()
+ (unix:unix-getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "cmucl")
+
+(defimplementation quit-lisp ()
+ (ext::quit))
+
+;;; source-path-{stream,file,string,etc}-position moved into
+;;; source-path-parser
+
+
+;;;; Debugging
+
+(defvar *sldb-stack-top*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (unix:unix-sigsetmask 0)
+ (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
+ (debug:*stack-top-hint* nil)
+ (kernel:*current-level* 0))
+ (handler-bind ((di::unhandled-condition
+ (lambda (condition)
+ (error 'sldb-condition
+ :original-condition condition))))
+ (unwind-protect
+ (progn
+ #+(or)(sys:scrub-control-stack)
+ (funcall debugger-loop-fn))
+ #+(or)(sys:scrub-control-stack)
+ ))))
+
+(defun frame-down (frame)
+ (handler-case (di:frame-down frame)
+ (di:no-debug-info () nil)))
+
+(defun nth-frame (index)
+ (do ((frame *sldb-stack-top* (frame-down frame))
+ (i index (1- i)))
+ ((zerop i) frame)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (loop for f = (nth-frame start) then (frame-down f)
+ for i from start below end
+ while f collect f)))
+
+(defimplementation print-frame (frame stream)
+ (let ((*standard-output* stream))
+ (handler-case
+ (debug::print-frame-call frame :verbosity 1 :number nil)
+ (error (e)
+ (ignore-errors (princ e stream))))))
+
+(defimplementation frame-source-location (index)
+ (let ((frame (nth-frame index)))
+ (cond ((foreign-frame-p frame) (foreign-frame-source-location frame))
+ ((code-location-source-location (di:frame-code-location frame))))))
+
+(defimplementation eval-in-frame (form index)
+ (di:eval-in-frame (nth-frame index) form))
+
+(defun frame-debug-vars (frame)
+ "Return a vector of debug-variables in frame."
+ (let ((loc (di:frame-code-location frame)))
+ (remove-if
+ (lambda (v)
+ (not (eq (di:debug-variable-validity v loc) :valid)))
+ (di::debug-function-debug-variables (di:frame-debug-function frame)))))
+
+(defun debug-var-value (var frame)
+ (let* ((loc (di:frame-code-location frame))
+ (validity (di:debug-variable-validity var loc)))
+ (ecase validity
+ (:valid (di:debug-variable-value var frame))
+ ((:invalid :unknown) (make-symbol (string validity))))))
+
+(defimplementation frame-locals (index)
+ (let ((frame (nth-frame index)))
+ (loop for v across (frame-debug-vars frame)
+ collect (list :name (di:debug-variable-symbol v)
+ :id (di:debug-variable-id v)
+ :value (debug-var-value v frame)))))
+
+(defimplementation frame-var-value (frame var)
+ (let* ((frame (nth-frame frame))
+ (dvar (aref (frame-debug-vars frame) var)))
+ (debug-var-value dvar frame)))
+
+(defimplementation frame-catch-tags (index)
+ (mapcar #'car (di:frame-catches (nth-frame index))))
+
+(defimplementation frame-package (frame-number)
+ (let* ((frame (nth-frame frame-number))
+ (dbg-fun (di:frame-debug-function frame)))
+ (typecase dbg-fun
+ (di::compiled-debug-function
+ (let* ((comp (di::compiled-debug-function-component dbg-fun))
+ (dbg-info (kernel:%code-debug-info comp)))
+ (typecase dbg-info
+ (c::compiled-debug-info
+ (find-package (c::compiled-debug-info-package dbg-info)))))))))
+
+(defimplementation return-from-frame (index form)
+ (let ((sym (find-symbol (string 'find-debug-tag-for-frame)
+ :debug-internals)))
+ (if sym
+ (let* ((frame (nth-frame index))
+ (probe (funcall sym frame)))
+ (cond (probe (throw (car probe) (eval-in-frame form index)))
+ (t (format nil "Cannot return from frame: ~S" frame))))
+ "return-from-frame is not implemented in this version of CMUCL.")))
+
+(defimplementation activate-stepping (frame)
+ (set-step-breakpoints (nth-frame frame)))
+
+(defimplementation sldb-break-on-return (frame)
+ (break-on-return (nth-frame frame)))
+
+;;; We set the breakpoint in the caller which might be a bit confusing.
+;;;
+(defun break-on-return (frame)
+ (let* ((caller (di:frame-down frame))
+ (cl (di:frame-code-location caller)))
+ (flet ((hook (frame bp)
+ (when (frame-pointer= frame caller)
+ (di:delete-breakpoint bp)
+ (signal-breakpoint bp frame))))
+ (let* ((info (ecase (di:code-location-kind cl)
+ ((:single-value-return :unknown-return) nil)
+ (:known-return (debug-function-returns
+ (di:frame-debug-function frame)))))
+ (bp (di:make-breakpoint #'hook cl :kind :code-location
+ :info info)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~A" caller))))))
+
+(defun frame-pointer= (frame1 frame2)
+ "Return true if the frame pointers of FRAME1 and FRAME2 are the same."
+ (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
+
+;;; The PC in escaped frames at a single-return-value point is
+;;; actually vm:single-value-return-byte-offset bytes after the
+;;; position given in the debug info. Here we try to recognize such
+;;; cases.
+;;;
+(defun next-code-locations (frame code-location)
+ "Like `debug::next-code-locations' but be careful in escaped frames."
+ (let ((next (debug::next-code-locations code-location)))
+ (flet ((adjust-pc ()
+ (let ((cl (di::copy-compiled-code-location code-location)))
+ (incf (di::compiled-code-location-pc cl)
+ vm:single-value-return-byte-offset)
+ cl)))
+ (cond ((and (di::compiled-frame-escaped frame)
+ (eq (di:code-location-kind code-location)
+ :single-value-return)
+ (= (length next) 1)
+ (di:code-location= (car next) (adjust-pc)))
+ (debug::next-code-locations (car next)))
+ (t
+ next)))))
+
+(defun set-step-breakpoints (frame)
+ (let ((cl (di:frame-code-location frame)))
+ (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
+ (error "Cannot step in elsewhere code"))
+ (let* ((debug::*bad-code-location-types*
+ (remove :call-site debug::*bad-code-location-types*))
+ (next (next-code-locations frame cl)))
+ (cond (next
+ (let ((steppoints '()))
+ (flet ((hook (bp-frame bp)
+ (signal-breakpoint bp bp-frame)
+ (mapc #'di:delete-breakpoint steppoints)))
+ (dolist (code-location next)
+ (let ((bp (di:make-breakpoint #'hook code-location
+ :kind :code-location)))
+ (di:activate-breakpoint bp)
+ (push bp steppoints))))))
+ (t
+ (break-on-return frame))))))
+
+
+;; XXX the return values at return breakpoints should be passed to the
+;; user hooks. debug-int.lisp should be changed to do this cleanly.
+
+;;; The sigcontext and the PC for a breakpoint invocation are not
+;;; passed to user hook functions, but we need them to extract return
+;;; values. So we advice di::handle-breakpoint and bind the values to
+;;; special variables.
+;;;
+(defvar *breakpoint-sigcontext*)
+(defvar *breakpoint-pc*)
+
+(define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext)
+ (let ((*breakpoint-sigcontext* sigcontext)
+ (*breakpoint-pc* offset))
+ (call-next-function)))
+(set-fwrappers 'di::handle-breakpoint '())
+(fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext)
+
+(defun sigcontext-object (sc index)
+ "Extract the lisp object in sigcontext SC at offset INDEX."
+ (kernel:make-lisp-obj (vm:sigcontext-register sc index)))
+
+(defun known-return-point-values (sigcontext sc-offsets)
+ (let ((fp (system:int-sap (vm:sigcontext-register sigcontext
+ vm::cfp-offset))))
+ (system:without-gcing
+ (loop for sc-offset across sc-offsets
+ collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
+
+;;; CMUCL returns the first few values in registers and the rest on
+;;; the stack. In the multiple value case, the number of values is
+;;; stored in a dedicated register. The values of the registers can be
+;;; accessed in the sigcontext for the breakpoint. There are 3 kinds
+;;; of return conventions: :single-value-return, :unknown-return, and
+;;; :known-return.
+;;;
+;;; The :single-value-return convention returns the value in a
+;;; register without setting the nargs registers.
+;;;
+;;; The :unknown-return variant is used for multiple values. A
+;;; :unknown-return point consists actually of 2 breakpoints: one for
+;;; the single value case and one for the general case. The single
+;;; value breakpoint comes vm:single-value-return-byte-offset after
+;;; the multiple value breakpoint.
+;;;
+;;; The :known-return convention is used by local functions.
+;;; :known-return is currently not supported because we don't know
+;;; where the values are passed.
+;;;
+(defun breakpoint-values (breakpoint)
+ "Return the list of return values for a return point."
+ (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
+ (let ((sc (locally (declare (optimize (speed 0)))
+ (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext))))
+ (cl (di:breakpoint-what breakpoint)))
+ (ecase (di:code-location-kind cl)
+ (:single-value-return
+ (list (1st sc)))
+ (:known-return
+ (let ((info (di:breakpoint-info breakpoint)))
+ (if (vectorp info)
+ (known-return-point-values sc info)
+ (progn
+ ;;(break)
+ (list "<<known-return convention not supported>>" info)))))
+ (:unknown-return
+ (let ((mv-return-pc (di::compiled-code-location-pc cl)))
+ (if (= mv-return-pc *breakpoint-pc*)
+ (mv-function-end-breakpoint-values sc)
+ (list (1st sc)))))))))
+
+;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in
+;; newer versions of CMUCL (after ~March 2005).
+(defun mv-function-end-breakpoint-values (sigcontext)
+ (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di)))
+ (cond (sym (funcall sym sigcontext))
+ (t (funcall 'di::get-function-end-breakpoint-values sigcontext)))))
+
+(defun debug-function-returns (debug-fun)
+ "Return the return style of DEBUG-FUN."
+ (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
+ (c::compiled-debug-function-returns cdfun)))
+
+(define-condition breakpoint (simple-condition)
+ ((message :initarg :message :reader breakpoint.message)
+ (values :initarg :values :reader breakpoint.values))
+ (:report (lambda (c stream) (princ (breakpoint.message c) stream))))
+
+(defimplementation condition-extras (condition)
+ (typecase condition
+ (breakpoint
+ ;; pop up the source buffer
+ `((:show-frame-source 0)))
+ (t '())))
+
+(defun signal-breakpoint (breakpoint frame)
+ "Signal a breakpoint condition for BREAKPOINT in FRAME.
+Try to create a informative message."
+ (flet ((brk (values fstring &rest args)
+ (let ((msg (apply #'format nil fstring args))
+ (debug:*stack-top-hint* frame))
+ (break 'breakpoint :message msg :values values))))
+ (with-struct (di::breakpoint- kind what) breakpoint
+ (case kind
+ (:code-location
+ (case (di:code-location-kind what)
+ ((:single-value-return :known-return :unknown-return)
+ (let ((values (breakpoint-values breakpoint)))
+ (brk values "Return value: ~{~S ~}" values)))
+ (t
+ #+(or)
+ (when (eq (di:code-location-kind what) :call-site)
+ (call-site-function breakpoint frame))
+ (brk nil "Breakpoint: ~S ~S"
+ (di:code-location-kind what)
+ (di::compiled-code-location-pc what)))))
+ (:function-start
+ (brk nil "Function start breakpoint"))
+ (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
+
+(defimplementation sldb-break-at-start (fname)
+ (let ((debug-fun (di:function-debug-function (coerce fname 'function))))
+ (cond ((not debug-fun)
+ `(:error ,(format nil "~S has no debug-function" fname)))
+ (t
+ (flet ((hook (frame bp &optional args cookie)
+ (declare (ignore args cookie))
+ (signal-breakpoint bp frame)))
+ (let ((bp (di:make-breakpoint #'hook debug-fun
+ :kind :function-start)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
+
+(defun frame-cfp (frame)
+ "Return the Control-Stack-Frame-Pointer for FRAME."
+ (etypecase frame
+ (di::compiled-frame (di::frame-pointer frame))
+ ((or di::interpreted-frame null) -1)))
+
+(defun frame-ip (frame)
+ "Return the (absolute) instruction pointer and the relative pc of FRAME."
+ (if (not frame)
+ -1
+ (let ((debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((code-loc (di:frame-code-location frame))
+ (component (di::compiled-debug-function-component debug-fun))
+ (pc (di::compiled-code-location-pc code-loc))
+ (ip (sys:without-gcing
+ (sys:sap-int
+ (sys:sap+ (kernel:code-instructions component) pc)))))
+ (values ip pc)))
+ (di::interpreted-debug-function -1)
+ (di::bogus-debug-function
+ #-x86
+ (let* ((real (di::frame-real-frame (di::frame-up frame)))
+ (fp (di::frame-pointer real)))
+ ;;#+(or)
+ (progn
+ (format *debug-io* "Frame-real-frame = ~S~%" real)
+ (format *debug-io* "fp = ~S~%" fp)
+ (format *debug-io* "lra = ~S~%"
+ (kernel:stack-ref fp vm::lra-save-offset)))
+ (values
+ (sys:int-sap
+ (- (kernel:get-lisp-obj-address
+ (kernel:stack-ref fp vm::lra-save-offset))
+ (- (ash vm:function-code-offset vm:word-shift)
+ vm:function-pointer-type)))
+ 0))
+ #+x86
+ (let ((fp (di::frame-pointer (di:frame-up frame))))
+ (multiple-value-bind (ra ofp) (di::x86-call-context fp)
+ (declare (ignore ofp))
+ (values ra 0))))))))
+
+(defun frame-registers (frame)
+ "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
+ (let* ((cfp (frame-cfp frame))
+ (csp (frame-cfp (di::frame-up frame)))
+ (ip (frame-ip frame))
+ (ocfp (frame-cfp (di::frame-down frame)))
+ (lra (frame-ip (di::frame-down frame))))
+ (values csp cfp ip ocfp lra)))
+
+(defun print-frame-registers (frame-number)
+ (let ((frame (di::frame-real-frame (nth-frame frame-number))))
+ (flet ((fixnum (p) (etypecase p
+ (integer p)
+ (sys:system-area-pointer (sys:sap-int p)))))
+ (apply #'format t "~
+~8X Stack Pointer
+~8X Frame Pointer
+~8X Instruction Pointer
+~8X Saved Frame Pointer
+~8X Saved Instruction Pointer~%" (mapcar #'fixnum
+ (multiple-value-list (frame-registers frame)))))))
+
+(defvar *gdb-program-name*
+ (ext:enumerate-search-list (p "path:gdb")
+ (when (probe-file p)
+ (return p))))
+
+(defimplementation disassemble-frame (frame-number)
+ (print-frame-registers frame-number)
+ (terpri)
+ (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
+ (debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((component (di::compiled-debug-function-component debug-fun))
+ (fun (di:debug-function-function debug-fun)))
+ (if fun
+ (disassemble fun)
+ (disassem:disassemble-code-component component))))
+ (di::bogus-debug-function
+ (cond ((probe-file *gdb-program-name*)
+ (let ((ip (sys:sap-int (frame-ip frame))))
+ (princ (gdb-command "disas 0x~x" ip))))
+ (t
+ (format t "~%[Disassembling bogus frames not implemented]")))))))
+
+(defmacro with-temporary-file ((stream filename) &body body)
+ `(call/temporary-file (lambda (,stream ,filename) . ,body)))
+
+(defun call/temporary-file (fun)
+ (let ((name (system::pick-temporary-file-name)))
+ (unwind-protect
+ (with-open-file (stream name :direction :output :if-exists :supersede)
+ (funcall fun stream name))
+ (delete-file name))))
+
+(defun gdb-command (format-string &rest args)
+ (let ((str (gdb-exec (format nil
+ "interpreter-exec mi2 \"attach ~d\"~%~
+ interpreter-exec console ~s~%detach"
+ (getpid)
+ (apply #'format nil format-string args))))
+ (prompt (format nil
+ #-(and darwin x86) "~%^done~%(gdb) ~%"
+ #+(and darwin x86)
+"~%^done,thread-id=\"1\"~%(gdb) ~%")))
+ (subseq str (+ (or (search prompt str) 0) (length prompt)))))
+
+(defun gdb-exec (cmd)
+ (with-temporary-file (file filename)
+ (write-string cmd file)
+ (force-output file)
+ (let* ((output (make-string-output-stream))
+ ;; gdb on sparc needs to know the executable to find the
+ ;; symbols. Without this, gdb can't disassemble anything.
+ ;; NOTE: We assume that the first entry in
+ ;; lisp::*cmucl-lib* is the bin directory where lisp is
+ ;; located. If this is not true, we'll have to do
+ ;; something better to find the lisp executable.
+ (lisp-path
+ #+sparc
+ (list
+ (namestring
+ (probe-file
+ (merge-pathnames "lisp" (car (lisp::parse-unix-search-path
+ lisp::*cmucl-lib*))))))
+ #-sparc
+ nil)
+ (proc (ext:run-program *gdb-program-name*
+ `(,@lisp-path "-batch" "-x" ,filename)
+ :wait t
+ :output output)))
+ (assert (eq (ext:process-status proc) :exited))
+ (assert (eq (ext:process-exit-code proc) 0))
+ (get-output-stream-string output))))
+
+(defun foreign-frame-p (frame)
+ #-x86
+ (let ((ip (frame-ip frame)))
+ (and (sys:system-area-pointer-p ip)
+ (typep (di::frame-debug-function frame) 'di::bogus-debug-function)))
+ #+x86
+ (let ((ip (frame-ip frame)))
+ (and (sys:system-area-pointer-p ip)
+ (multiple-value-bind (pc code)
+ (di::compute-lra-data-from-pc ip)
+ (declare (ignore pc))
+ (not code)))))
+
+(defun foreign-frame-source-location (frame)
+ (let ((ip (sys:sap-int (frame-ip frame))))
+ (cond ((probe-file *gdb-program-name*)
+ (parse-gdb-line-info (gdb-command "info line *0x~x" ip)))
+ (t `(:error "no srcloc available for ~a" frame)))))
+
+;; The output of gdb looks like:
+;; Line 215 of "../../src/lisp/x86-assem.S"
+;; starts at address 0x805318c <Ldone+11>
+;; and ends at 0x805318e <Ldone+13>.
+;; The ../../ are fixed up with the "target:" search list which might
+;; be wrong sometimes.
+(defun parse-gdb-line-info (string)
+ (with-input-from-string (*standard-input* string)
+ (let ((w1 (read-word)))
+ (cond ((equal w1 "Line")
+ (let ((line (read-word)))
+ (assert (equal (read-word) "of"))
+ (let* ((file (read-from-string (read-word)))
+ (pathname
+ (or (probe-file file)
+ (probe-file (format nil "target:lisp/~a" file))
+ file)))
+ (make-location (list :file (unix-truename pathname))
+ (list :line (parse-integer line))))))
+ (t
+ `(:error ,string))))))
+
+(defun read-word (&optional (stream *standard-input*))
+ (peek-char t stream)
+ (concatenate 'string (loop until (whitespacep (peek-char nil stream))
+ collect (read-char stream))))
+
+(defun whitespacep (char)
+ (member char '(#\space #\newline)))
+
+
+;;;; Inspecting
+
+(defconstant +lowtag-symbols+
+ '(vm:even-fixnum-type
+ vm:function-pointer-type
+ vm:other-immediate-0-type
+ vm:list-pointer-type
+ vm:odd-fixnum-type
+ vm:instance-pointer-type
+ vm:other-immediate-1-type
+ vm:other-pointer-type)
+ "Names of the constants that specify type tags.
+The `symbol-value' of each element is a type tag.")
+
+(defconstant +header-type-symbols+
+ (labels ((suffixp (suffix string)
+ (and (>= (length string) (length suffix))
+ (string= string suffix :start1 (- (length string)
+ (length suffix)))))
+ (header-type-symbol-p (x)
+ (and (suffixp "-TYPE" (symbol-name x))
+ (not (member x +lowtag-symbols+))
+ (boundp x)
+ (typep (symbol-value x) 'fixnum))))
+ (remove-if-not #'header-type-symbol-p
+ (append (apropos-list "-TYPE" "VM")
+ (apropos-list "-TYPE" "BIGNUM"))))
+ "A list of names of the type codes in boxed objects.")
+
+(defimplementation describe-primitive-type (object)
+ (with-output-to-string (*standard-output*)
+ (let* ((lowtag (kernel:get-lowtag object))
+ (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
+ (format t "lowtag: ~A" lowtag-symbol)
+ (when (member lowtag (list vm:other-pointer-type
+ vm:function-pointer-type
+ vm:other-immediate-0-type
+ vm:other-immediate-1-type
+ ))
+ (let* ((type (kernel:get-type object))
+ (type-symbol (find type +header-type-symbols+
+ :key #'symbol-value)))
+ (format t ", type: ~A" type-symbol))))))
+
+(defmethod emacs-inspect ((o t))
+ (cond ((di::indirect-value-cell-p o)
+ `("Value: " (:value ,(c:value-cell-ref o))))
+ ((alien::alien-value-p o)
+ (inspect-alien-value o))
+ (t
+ (cmucl-inspect o))))
+
+(defun cmucl-inspect (o)
+ (destructuring-bind (text labeledp . parts) (inspect::describe-parts o)
+ (list* (format nil "~A~%" text)
+ (if labeledp
+ (loop for (label . value) in parts
+ append (label-value-line label value))
+ (loop for value in parts for i from 0
+ append (label-value-line i value))))))
+
+(defmethod emacs-inspect ((o function))
+ (let ((header (kernel:get-type o)))
+ (cond ((= header vm:function-header-type)
+ (append (label-value-line*
+ ("Self" (kernel:%function-self o))
+ ("Next" (kernel:%function-next o))
+ ("Name" (kernel:%function-name o))
+ ("Arglist" (kernel:%function-arglist o))
+ ("Type" (kernel:%function-type o))
+ ("Code" (kernel:function-code-header o)))
+ (list
+ (with-output-to-string (s)
+ (disassem:disassemble-function o :stream s)))))
+ ((= header vm:closure-header-type)
+ (list* (format nil "~A is a closure.~%" o)
+ (append
+ (label-value-line "Function" (kernel:%closure-function o))
+ `("Environment:" (:newline))
+ (loop for i from 0 below (1- (kernel:get-closure-length o))
+ append (label-value-line
+ i (kernel:%closure-index-ref o i))))))
+ ((eval::interpreted-function-p o)
+ (cmucl-inspect o))
+ (t
+ (call-next-method)))))
+
+(defmethod emacs-inspect ((o kernel:funcallable-instance))
+ (append (label-value-line*
+ (:function (kernel:%funcallable-instance-function o))
+ (:lexenv (kernel:%funcallable-instance-lexenv o))
+ (:layout (kernel:%funcallable-instance-layout o)))
+ (cmucl-inspect o)))
+
+(defmethod emacs-inspect ((o kernel:code-component))
+ (append
+ (label-value-line*
+ ("code-size" (kernel:%code-code-size o))
+ ("entry-points" (kernel:%code-entry-points o))
+ ("debug-info" (kernel:%code-debug-info o))
+ ("trace-table-offset" (kernel:code-header-ref
+ o vm:code-trace-table-offset-slot)))
+ `("Constants:" (:newline))
+ (loop for i from vm:code-constants-offset
+ below (kernel:get-header-data o)
+ append (label-value-line i (kernel:code-header-ref o i)))
+ `("Code:"
+ (:newline)
+ , (with-output-to-string (*standard-output*)
+ (cond ((c::compiled-debug-info-p (kernel:%code-debug-info o))
+ (disassem:disassemble-code-component o))
+ ((or
+ (c::debug-info-p (kernel:%code-debug-info o))
+ (consp (kernel:code-header-ref
+ o vm:code-trace-table-offset-slot)))
+ (c:disassem-byte-component o))
+ (t
+ (disassem:disassemble-memory
+ (disassem::align
+ (+ (logandc2 (kernel:get-lisp-obj-address o)
+ vm:lowtag-mask)
+ (* vm:code-constants-offset vm:word-bytes))
+ (ash 1 vm:lowtag-bits))
+ (ash (kernel:%code-code-size o) vm:word-shift))))))))
+
+(defmethod emacs-inspect ((o kernel:fdefn))
+ (label-value-line*
+ ("name" (kernel:fdefn-name o))
+ ("function" (kernel:fdefn-function o))
+ ("raw-addr" (sys:sap-ref-32
+ (sys:int-sap (kernel:get-lisp-obj-address o))
+ (* vm:fdefn-raw-addr-slot vm:word-bytes)))))
+
+#+(or)
+(defmethod emacs-inspect ((o array))
+ (if (typep o 'simple-array)
+ (call-next-method)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:rank (array-rank o))
+ (:fill-pointer (kernel:%array-fill-pointer o))
+ (:fill-pointer-p (kernel:%array-fill-pointer-p o))
+ (:elements (kernel:%array-available-elements o))
+ (:data (kernel:%array-data-vector o))
+ (:displacement (kernel:%array-displacement o))
+ (:displaced-p (kernel:%array-displaced-p o))
+ (:dimensions (array-dimensions o)))))
+
+(defmethod emacs-inspect ((o simple-vector))
+ (append
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:length (c::vector-length o)))
+ (loop for i below (length o)
+ append (label-value-line i (aref o i)))))
+
+(defun inspect-alien-record (alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (with-struct (alien::alien-record-type- kind name fields) type
+ (append
+ (label-value-line*
+ (:sap sap)
+ (:kind kind)
+ (:name name))
+ (loop for field in fields
+ append (let ((slot (alien::alien-record-field-name field)))
+ (declare (optimize (speed 0)))
+ (label-value-line slot (alien:slot alien slot))))))))
+
+(defun inspect-alien-pointer (alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (label-value-line*
+ (:sap sap)
+ (:type type)
+ (:to (alien::deref alien)))))
+
+(defun inspect-alien-value (alien)
+ (typecase (alien::alien-value-type alien)
+ (alien::alien-record-type (inspect-alien-record alien))
+ (alien::alien-pointer-type (inspect-alien-pointer alien))
+ (t (cmucl-inspect alien))))
+
+(defimplementation eval-context (obj)
+ (cond ((typep (class-of obj) 'structure-class)
+ (let* ((dd (kernel:layout-info (kernel:layout-of obj)))
+ (slots (kernel:dd-slots dd)))
+ (list* (cons '*package*
+ (symbol-package (if slots
+ (kernel:dsd-name (car slots))
+ (kernel:dd-name dd))))
+ (loop for slot in slots collect
+ (cons (kernel:dsd-name slot)
+ (funcall (kernel:dsd-accessor slot) obj))))))))
+
+
+;;;; Profiling
+(defimplementation profile (fname)
+ (eval `(profile:profile ,fname)))
+
+(defimplementation unprofile (fname)
+ (eval `(profile:unprofile ,fname)))
+
+(defimplementation unprofile-all ()
+ (eval `(profile:unprofile))
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (eval `(profile:report-time)))
+
+(defimplementation profile-reset ()
+ (eval `(profile:reset-time))
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ profile:*timed-functions*)
+
+(defimplementation profile-package (package callers methods)
+ (profile:profile-all :package package
+ :callers-p callers
+ :methods methods))
+
+
+;;;; Multiprocessing
+
+#+mp
+(progn
+ (defimplementation initialize-multiprocessing (continuation)
+ (mp::init-multi-processing)
+ (mp:make-process continuation :name "swank")
+ ;; Threads magic: this never returns! But top-level becomes
+ ;; available again.
+ (unless mp::*idle-process*
+ (mp::startup-idle-and-top-level-loops)))
+
+ (defimplementation spawn (fn &key name)
+ (mp:make-process fn :name (or name "Anonymous")))
+
+ (defvar *thread-id-counter* 0)
+
+ (defimplementation thread-id (thread)
+ (or (getf (mp:process-property-list thread) 'id)
+ (setf (getf (mp:process-property-list thread) 'id)
+ (incf *thread-id-counter*))))
+
+ (defimplementation find-thread (id)
+ (find id (all-threads)
+ :key (lambda (p) (getf (mp:process-property-list p) 'id))))
+
+ (defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+ (defimplementation thread-status (thread)
+ (mp:process-whostate thread))
+
+ (defimplementation current-thread ()
+ mp:*current-process*)
+
+ (defimplementation all-threads ()
+ (copy-list mp:*all-processes*))
+
+ (defimplementation interrupt-thread (thread fn)
+ (mp:process-interrupt thread fn))
+
+ (defimplementation kill-thread (thread)
+ (mp:destroy-process thread))
+
+ (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
+
+ (defstruct (mailbox (:conc-name mailbox.))
+ (mutex (mp:make-lock "process mailbox"))
+ (queue '() :type list))
+
+ (defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-lock-held (*mailbox-lock*)
+ (or (getf (mp:process-property-list thread) 'mailbox)
+ (setf (getf (mp:process-property-list thread) 'mailbox)
+ (make-mailbox)))))
+
+ (defimplementation send (thread message)
+ (check-slime-interrupts)
+ (let* ((mbox (mailbox thread)))
+ (mp:with-lock-held ((mailbox.mutex mbox))
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message))))))
+
+ (defimplementation receive-if (test &optional timeout)
+ (let ((mbox (mailbox mp:*current-process*)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (mp:with-lock-held ((mailbox.mutex mbox))
+ (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)))
+ (mp:process-wait-with-timeout
+ "receive-if" 0.5
+ (lambda () (some test (mailbox.queue mbox)))))))
+
+
+ ) ;; #+mp
+
+
+
+;;;; GC hooks
+;;;
+;;; Display GC messages in the echo area to avoid cluttering the
+;;; normal output.
+;;;
+
+;; this should probably not be here, but where else?
+(defun background-message (message)
+ (swank::background-message message))
+
+(defun print-bytes (nbytes &optional stream)
+ "Print the number NBYTES to STREAM in KB, MB, or GB units."
+ (let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb))))
+ (multiple-value-bind (power name)
+ (loop for ((p1 n1) (p2 n2)) on names
+ while n2 do
+ (when (<= (expt 2 p1) nbytes (1- (expt 2 p2)))
+ (return (values p1 n1))))
+ (cond (name
+ (format stream "~,1F ~A" (/ nbytes (expt 2 power)) name))
+ (t
+ (format stream "~:D bytes" nbytes))))))
+
+(defconstant gc-generations 6)
+
+#+gencgc
+(defun generation-stats ()
+ "Return a string describing the size distribution among the generations."
+ (let* ((alloc (loop for i below gc-generations
+ collect (lisp::gencgc-stats i)))
+ (sum (coerce (reduce #'+ alloc) 'float)))
+ (format nil "~{~3F~^/~}"
+ (mapcar (lambda (size) (/ size sum))
+ alloc))))
+
+(defvar *gc-start-time* 0)
+
+(defun pre-gc-hook (bytes-in-use)
+ (setq *gc-start-time* (get-internal-real-time))
+ (let ((msg (format nil "[Commencing GC with ~A in use.]"
+ (print-bytes bytes-in-use))))
+ (background-message msg)))
+
+(defun post-gc-hook (bytes-retained bytes-freed trigger)
+ (declare (ignore trigger))
+ (let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*)
+ internal-time-units-per-second))
+ (msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]"
+ (print-bytes bytes-freed)
+ (print-bytes bytes-retained)
+ #+gencgc(generation-stats)
+ #-gencgc""
+ seconds)))
+ (background-message msg)))
+
+(defun install-gc-hooks ()
+ (setq ext:*gc-notify-before* #'pre-gc-hook)
+ (setq ext:*gc-notify-after* #'post-gc-hook))
+
+(defun remove-gc-hooks ()
+ (setq ext:*gc-notify-before* #'lisp::default-gc-notify-before)
+ (setq ext:*gc-notify-after* #'lisp::default-gc-notify-after))
+
+(defvar *install-gc-hooks* t
+ "If non-nil install GC hooks")
+
+(defimplementation emacs-connected ()
+ (when *install-gc-hooks*
+ (install-gc-hooks)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;Trace implementations
+;;In CMUCL, we have:
+;; (trace <name>)
+;; (trace (method <name> <qualifier>? (<specializer>+)))
+;; (trace :methods t '<name>) ;;to trace all methods of the gf <name>
+;; <name> can be a normal name or a (setf name)
+
+(defun tracedp (spec)
+ (member spec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (spec &rest options)
+ (cond ((tracedp spec)
+ (eval `(untrace ,spec))
+ (format nil "~S is now untraced." spec))
+ (t
+ (eval `(trace ,spec ,@options))
+ (format nil "~S is now traced." spec))))
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ ((:defgeneric)
+ (let ((name (second spec)))
+ (toggle-trace-aux name :methods name)))
+ ((:defmethod)
+ (cond ((fboundp `(method ,@(cdr spec)))
+ (toggle-trace-aux `(method ,(cdr spec))))
+ ;; Man, is this ugly
+ ((fboundp `(pcl::fast-method ,@(cdr spec)))
+ (toggle-trace-aux `(pcl::fast-method ,@(cdr spec))))
+ (t
+ (error 'undefined-function :name (cdr spec)))))
+ ((:call)
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux (process-fspec callee)
+ :wherein (list (process-fspec caller)))))
+ ;; doesn't work properly
+ ;; ((:labels :flet) (toggle-trace-aux (process-fspec spec)))
+ ))
+
+(defun process-fspec (fspec)
+ (cond ((consp fspec)
+ (ecase (first fspec)
+ ((:defun :defgeneric) (second fspec))
+ ((:defmethod)
+ `(method ,(second fspec) ,@(third fspec) ,(fourth fspec)))
+ ((:labels) `(labels ,(third fspec) ,(process-fspec (second fspec))))
+ ((:flet) `(flet ,(third fspec) ,(process-fspec (second fspec))))))
+ (t
+ fspec)))
+
+;;; Weak datastructures
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-p t args))
+
+
+;;; Save image
+
+(defimplementation save-image (filename &optional restart-function)
+ (multiple-value-bind (pid error) (unix:unix-fork)
+ (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error)))
+ (cond ((= pid 0)
+ (apply #'ext:save-lisp
+ filename
+ (if restart-function
+ `(:init-function ,restart-function))))
+ (t
+ (let ((status (waitpid pid)))
+ (destructuring-bind (&key exited? status &allow-other-keys) status
+ (assert (and exited? (equal status 0)) ()
+ "Invalid exit status: ~a" status)))))))
+
+(defun waitpid (pid)
+ (alien:with-alien ((status c-call:int))
+ (let ((code (alien:alien-funcall
+ (alien:extern-alien
+ waitpid (alien:function c-call:int c-call:int
+ (* c-call:int) c-call:int))
+ pid (alien:addr status) 0)))
+ (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg)))
+ (t (assert (= code pid))
+ (decode-wait-status status))))))
+
+(defun decode-wait-status (status)
+ (let ((output (with-output-to-string (s)
+ (call-program (list (process-status-program)
+ (format nil "~d" status))
+ :output s))))
+ (read-from-string output)))
+
+(defun call-program (args &key output)
+ (destructuring-bind (program &rest args) args
+ (let ((process (ext:run-program program args :output output)))
+ (when (not program) (error "fork failed"))
+ (unless (and (eq (ext:process-status process) :exited)
+ (= (ext:process-exit-code process) 0))
+ (error "Non-zero exit status")))))
+
+(defvar *process-status-program* nil)
+
+(defun process-status-program ()
+ (or *process-status-program*
+ (setq *process-status-program*
+ (compile-process-status-program))))
+
+(defun compile-process-status-program ()
+ (let ((infile (system::pick-temporary-file-name
+ "/tmp/process-status~d~c.c")))
+ (with-open-file (stream infile :direction :output :if-exists :supersede)
+ (format stream "
+#include <stdio.h>
+#include <stdlib.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+#include <assert.h>
+
+#define FLAG(value) (value ? \"t\" : \"nil\")
+
+int main (int argc, char** argv) {
+ assert (argc == 2);
+ {
+ char* endptr = NULL;
+ char* arg = argv[1];
+ long int status = strtol (arg, &endptr, 10);
+ assert (endptr != arg && *endptr == '\\0');
+ printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\"
+ \" :stopped? %s :stopsig %d)\\n\",
+ FLAG(WIFEXITED(status)), WEXITSTATUS(status),
+ FLAG(WIFSIGNALED(status)), WTERMSIG(status),
+ FLAG(WCOREDUMP(status)),
+ FLAG(WIFSTOPPED(status)), WSTOPSIG(status));
+ fflush (NULL);
+ return 0;
+ }
+}
+")
+ (finish-output stream))
+ (let* ((outfile (system::pick-temporary-file-name))
+ (args (list "cc" "-o" outfile infile)))
+ (warn "Running cc: ~{~a ~}~%" args)
+ (call-program args :output t)
+ (delete-file infile)
+ outfile)))
+
+;; FIXME: lisp:unicode-complete introduced in version 20d.
+#+#.(swank/backend:with-symbol 'unicode-complete 'lisp)
+(defun match-semi-standard (prefix matchp)
+ ;; Handle the CMUCL's short character names.
+ (loop for name in lisp::char-name-alist
+ when (funcall matchp prefix (car name))
+ collect (car name)))
+
+#+#.(swank/backend:with-symbol 'unicode-complete 'lisp)
+(defimplementation character-completion-set (prefix matchp)
+ (let ((names (lisp::unicode-complete prefix)))
+ ;; Match prefix against semistandard names. If there's a match,
+ ;; add it to our list of matches.
+ (let ((semi-standard (match-semi-standard prefix matchp)))
+ (when semi-standard
+ (setf names (append semi-standard names))))
+ (setf names (mapcar #'string-capitalize names))
+ (loop for n in names
+ when (funcall matchp prefix n)
+ collect n)))
diff --git a/vim/bundle/slimv/slime/swank/corman.lisp b/vim/bundle/slimv/slime/swank/corman.lisp
new file mode 100644
index 0000000..80d9ddd
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/corman.lisp
@@ -0,0 +1,583 @@
+;;;
+;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
+;;;
+;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org)
+;;;
+;;; License
+;;; =======
+;;; This software is provided 'as-is', without any express or implied
+;;; warranty. In no event will the author be held liable for any damages
+;;; arising from the use of this software.
+;;;
+;;; Permission is granted to anyone to use this software for any purpose,
+;;; including commercial applications, and to alter it and redistribute
+;;; it freely, subject to the following restrictions:
+;;;
+;;; 1. The origin of this software must not be misrepresented; you must
+;;; not claim that you wrote the original software. If you use this
+;;; software in a product, an acknowledgment in the product documentation
+;;; would be appreciated but is not required.
+;;;
+;;; 2. Altered source versions must be plainly marked as such, and must
+;;; not be misrepresented as being the original software.
+;;;
+;;; 3. This notice may not be removed or altered from any source
+;;; distribution.
+;;;
+;;; Notes
+;;; =====
+;;; You will need CCL 2.51, and you will *definitely* need to patch
+;;; CCL with the patches at
+;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
+;;; will blow up in your face. You should also follow the
+;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
+;;;
+;;; The only communication style currently supported is NIL.
+;;;
+;;; Starting CCL inside emacs (with M-x slime) seems to work for me
+;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
+;;; (sometimes it works, other times it hangs on start or hangs when
+;;; initializing WinSock) - starting CCL externally and using M-x
+;;; slime-connect always works fine.
+;;;
+;;; Sometimes CCL gets confused and starts giving you random memory
+;;; access violation errors on startup; if this happens, try redumping
+;;; your image.
+;;;
+;;; What works
+;;; ==========
+;;; * Basic editing and evaluation
+;;; * Arglist display
+;;; * Compilation
+;;; * Loading files
+;;; * apropos/describe
+;;; * Debugger
+;;; * Inspector
+;;;
+;;; TODO
+;;; ====
+;;; * More debugger functionality (missing bits: restart-frame,
+;;; return-from-frame, disassemble-frame, activate-stepping,
+;;; toggle-trace)
+;;; * XREF
+;;; * Profiling
+;;; * More sophisticated communication styles than NIL
+;;;
+
+(in-package :swank/backend)
+
+;;; Pull in various needed bits
+(require :composite-streams)
+(require :sockets)
+(require :winbase)
+(require :lp)
+
+(use-package :gs)
+
+;; MOP stuff
+
+(defclass swank-mop:standard-slot-definition ()
+ ()
+ (:documentation
+ "Dummy class created so that swank.lisp will compile and load."))
+
+(defun named-by-gensym-p (c)
+ (null (symbol-package (class-name c))))
+
+(deftype swank-mop:eql-specializer ()
+ '(satisfies named-by-gensym-p))
+
+(defun swank-mop:eql-specializer-object (specializer)
+ (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
+ (loop (multiple-value-bind (more key value)
+ (next-entry)
+ (unless more (return nil))
+ (when (eq specializer value)
+ (return key))))))
+
+(defun swank-mop:class-finalized-p (class)
+ (declare (ignore class))
+ t)
+
+(defun swank-mop:class-prototype (class)
+ (make-instance class))
+
+(defun swank-mop:specializer-direct-methods (obj)
+ (declare (ignore obj))
+ nil)
+
+(defun swank-mop:generic-function-argument-precedence-order (gf)
+ (generic-function-lambda-list gf))
+
+(defun swank-mop:generic-function-method-combination (gf)
+ (declare (ignore gf))
+ :standard)
+
+(defun swank-mop:generic-function-declarations (gf)
+ (declare (ignore gf))
+ nil)
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (declare (ignore slot))
+ (getf slot :documentation nil))
+
+(defun swank-mop:slot-definition-type (slot)
+ (declare (ignore slot))
+ t)
+
+(import-swank-mop-symbols :cl '(;; classes
+ :standard-slot-definition
+ :eql-specializer
+ :eql-specializer-object
+ ;; standard class readers
+ :class-default-initargs
+ :class-direct-default-initargs
+ :class-finalized-p
+ :class-prototype
+ :specializer-direct-methods
+ ;; gf readers
+ :generic-function-argument-precedence-order
+ :generic-function-declarations
+ :generic-function-method-combination
+ ;; method readers
+ ;; slot readers
+ :slot-definition-documentation
+ :slot-definition-type))
+
+;;;; swank implementations
+
+;;; Debugger
+
+(defvar *stack-trace* nil)
+(defvar *frame-trace* nil)
+
+(defstruct frame
+ name function address debug-info variables)
+
+(defimplementation call-with-debugging-environment (fn)
+ (let* ((real-stack-trace (cl::stack-trace))
+ (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
+ :key #'car)))
+ (*frame-trace*
+ (let* ((db::*debug-level* (1+ db::*debug-level*))
+ (db::*debug-frame-pointer* (db::stash-ebp
+ (ct:create-foreign-ptr)))
+ (db::*debug-max-level* (length real-stack-trace))
+ (db::*debug-min-level* 1))
+ (cdr (member #'cl:invoke-debugger
+ (cons
+ (make-frame :function nil)
+ (loop for i from db::*debug-min-level*
+ upto db::*debug-max-level*
+ until (eq (db::get-frame-function i)
+ cl::*top-level*)
+ collect
+ (make-frame
+ :function (db::get-frame-function i)
+ :address (db::get-frame-address i))))
+ :key #'frame-function)))))
+ (funcall fn)))
+
+(defimplementation compute-backtrace (start end)
+ (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
+ collect f))
+
+(defimplementation print-frame (frame stream)
+ (format stream "~S" frame))
+
+(defun get-frame-debug-info (frame)
+ (or (frame-debug-info frame)
+ (setf (frame-debug-info frame)
+ (db::prepare-frame-debug-info (frame-function frame)
+ (frame-address frame)))))
+
+(defimplementation frame-locals (frame-number)
+ (let* ((frame (elt *frame-trace* frame-number))
+ (info (get-frame-debug-info frame)))
+ (let ((var-list
+ (loop for i from 4 below (length info) by 2
+ collect `(list :name ',(svref info i) :id 0
+ :value (db::debug-filter ,(svref info i))))))
+ (let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
+ (setf (frame-variables frame) vars)))))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((frame (elt *frame-trace* frame-number)))
+ (let ((cl::*compiler-environment* (get-frame-debug-info frame)))
+ (eval form))))
+
+(defimplementation frame-var-value (frame-number var)
+ (let ((vars (frame-variables (elt *frame-trace* frame-number))))
+ (when vars
+ (second (elt vars var)))))
+
+(defimplementation frame-source-location (frame-number)
+ (fspec-location (frame-function (elt *frame-trace* frame-number))))
+
+(defun break (&optional (format-control "Break") &rest format-arguments)
+ (with-simple-restart (continue "Return from BREAK.")
+ (let ();(*debugger-hook* nil))
+ (let ((condition
+ (make-condition 'simple-condition
+ :format-control format-control
+ :format-arguments format-arguments)))
+ ;;(format *debug-io* ";;; User break: ~A~%" condition)
+ (invoke-debugger condition))))
+ nil)
+
+;;; Socket communication
+
+(defimplementation create-socket (host port &key backlog)
+ (sockets:start-sockets)
+ (sockets:make-server-socket :host host :port port))
+
+(defimplementation local-port (socket)
+ (sockets:socket-port socket))
+
+(defimplementation close-socket (socket)
+ (close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout external-format))
+ (sockets:make-socket-stream (sockets:accept-socket socket)))
+
+;;; Misc
+
+(defimplementation preferred-communication-style ()
+ nil)
+
+(defimplementation getpid ()
+ ccl:*current-process-id*)
+
+(defimplementation lisp-implementation-type-name ()
+ "cormanlisp")
+
+(defimplementation quit-lisp ()
+ (sockets:stop-sockets)
+ (win32:exitprocess 0))
+
+(defimplementation set-default-directory (directory)
+ (setf (ccl:current-directory) directory)
+ (directory-namestring (setf *default-pathname-defaults*
+ (truename (merge-pathnames directory)))))
+
+(defimplementation default-directory ()
+ (directory-namestring (ccl:current-directory)))
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (ccl:macroexpand-all form))
+
+;;; Documentation
+
+(defun fspec-location (fspec)
+ (when (symbolp fspec)
+ (setq fspec (symbol-function fspec)))
+ (let ((file (ccl::function-source-file fspec)))
+ (if file
+ (handler-case
+ (let ((truename (truename
+ (merge-pathnames file
+ ccl:*cormanlisp-directory*))))
+ (make-location (list :file (namestring truename))
+ (if (ccl::function-source-line fspec)
+ (list :line
+ (1+ (ccl::function-source-line fspec)))
+ (list :function-name
+ (princ-to-string
+ (function-name fspec))))))
+ (error (c) (list :error (princ-to-string c))))
+ (list :error (format nil "No source information available for ~S"
+ fspec)))))
+
+(defimplementation find-definitions (name)
+ (list (list name (fspec-location name))))
+
+(defimplementation arglist (name)
+ (handler-case
+ (cond ((and (symbolp name)
+ (macro-function name))
+ (ccl::macro-lambda-list (symbol-function name)))
+ (t
+ (when (symbolp name)
+ (setq name (symbol-function name)))
+ (if (eq (class-of name) cl::the-class-standard-gf)
+ (generic-function-lambda-list name)
+ (ccl:function-lambda-list name))))
+ (error () :not-available)))
+
+(defimplementation function-name (fn)
+ (handler-case (getf (cl::function-info-list fn) 'cl::function-name)
+ (error () nil)))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :function (if (fboundp symbol)
+ (doc 'function)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+;;; Compiler
+
+(defvar *buffer-name* nil)
+(defvar *buffer-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename* nil)
+
+;; FIXME
+(defimplementation call-with-compilation-hooks (FN)
+ (handler-bind ((error (lambda (c)
+ (signal 'compiler-condition
+ :original-condition c
+ :severity :warning
+ :message (format nil "~A" c)
+ :location
+ (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (list :offset *buffer-position* 0)))
+ (*compile-filename*
+ (make-location
+ (list :file *compile-filename*)
+ (list :position 1)))
+ (t
+ (list :error "No location")))))))
+ (funcall fn)))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore external-format policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (*compile-filename* input-file))
+ (multiple-value-bind (output-file warnings? failure?)
+ (compile-file input-file :output-file output-file)
+ (values output-file warnings?
+ (or failure? (and load-p (load output-file))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore filename policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-position* position)
+ (*buffer-string* string))
+ (funcall (compile nil (read-from-string
+ (format nil "(~S () ~A)" 'lambda string))))
+ t)))
+
+;;;; Inspecting
+
+;; Hack to make swank.lisp load, at least
+(defclass file-stream ())
+
+(defun comma-separated (list &optional (callback (lambda (v)
+ `(:value ,v))))
+ (butlast (loop for e in list
+ collect (funcall callback e)
+ collect ", ")))
+
+(defmethod emacs-inspect ((class standard-class))
+ `("Name: "
+ (:value ,(class-name class))
+ (:newline)
+ "Super classes: "
+ ,@(comma-separated (swank-mop:class-direct-superclasses class))
+ (:newline)
+ "Direct Slots: "
+ ,@(comma-separated
+ (swank-mop:class-direct-slots class)
+ (lambda (slot)
+ `(:value ,slot
+ ,(princ-to-string
+ (swank-mop:slot-definition-name slot)))))
+ (:newline)
+ "Effective Slots: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (comma-separated
+ (swank-mop:class-slots class)
+ (lambda (slot)
+ `(:value ,slot ,(princ-to-string
+ (swank-mop:slot-definition-name slot)))))
+ '("#<N/A (class not finalized)>"))
+ (:newline)
+ ,@(when (documentation class t)
+ `("Documentation:" (:newline) ,(documentation class t) (:newline)))
+ "Sub classes: "
+ ,@(comma-separated (swank-mop:class-direct-subclasses class)
+ (lambda (sub)
+ `(:value ,sub ,(princ-to-string (class-name sub)))))
+ (:newline)
+ "Precedence List: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (comma-separated
+ (swank-mop:class-precedence-list class)
+ (lambda (class)
+ `(:value ,class
+ ,(princ-to-string (class-name class)))))
+ '("#<N/A (class not finalized)>"))
+ (:newline)))
+
+(defmethod emacs-inspect ((slot cons))
+ ;; Inspects slot definitions
+ (if (eq (car slot) :name)
+ `("Name: " (:value ,(swank-mop:slot-definition-name slot))
+ (:newline)
+ ,@(when (swank-mop:slot-definition-documentation slot)
+ `("Documentation:"
+ (:newline)
+ (:value
+ ,(swank-mop:slot-definition-documentation slot))
+ (:newline)))
+ "Init args: " (:value
+ ,(swank-mop:slot-definition-initargs slot))
+ (:newline)
+ "Init form: "
+ ,(if (swank-mop:slot-definition-initfunction slot)
+ `(:value ,(swank-mop:slot-definition-initform slot))
+ "#<unspecified>") (:newline)
+ "Init function: "
+ (:value ,(swank-mop:slot-definition-initfunction slot))
+ (:newline))
+ (call-next-method)))
+
+(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
+ (list* (if (wild-pathname-p pathname)
+ "A wild pathname."
+ "A pathname.")
+ '(:newline)
+ (append (label-value-line*
+ ("Namestring" (namestring pathname))
+ ("Host" (pathname-host pathname))
+ ("Device" (pathname-device pathname))
+ ("Directory" (pathname-directory pathname))
+ ("Name" (pathname-name pathname))
+ ("Type" (pathname-type pathname))
+ ("Version" (pathname-version pathname)))
+ (unless (or (wild-pathname-p pathname)
+ (not (probe-file pathname)))
+ (label-value-line "Truename" (truename pathname))))))
+
+(defmethod emacs-inspect ((o t))
+ (cond ((cl::structurep o) (inspect-structure o))
+ (t (call-next-method))))
+
+(defun inspect-structure (o)
+ (let* ((template (cl::uref o 1))
+ (num-slots (cl::struct-template-num-slots template)))
+ (cond ((symbolp template)
+ (loop for i below num-slots
+ append (label-value-line i (cl::uref o (+ 2 i)))))
+ (t
+ (loop for i below num-slots
+ append (label-value-line (elt template (+ 6 (* i 5)))
+ (cl::uref o (+ 2 i))))))))
+
+
+;;; Threads
+
+(require 'threads)
+
+(defstruct (mailbox (:conc-name mailbox.))
+ thread
+ (lock (make-instance 'threads:critical-section))
+ (queue '() :type list))
+
+(defvar *mailbox-lock* (make-instance 'threads:critical-section))
+(defvar *mailboxes* (list))
+
+(defmacro with-lock (lock &body body)
+ `(threads:with-synchronization (threads:cs ,lock)
+ ,@body))
+
+(defimplementation spawn (fun &key name)
+ (declare (ignore name))
+ (th:create-thread
+ (lambda ()
+ (handler-bind ((serious-condition #'invoke-debugger))
+ (unwind-protect (funcall fun)
+ (with-lock *mailbox-lock*
+ (setq *mailboxes* (remove cormanlisp:*current-thread-id*
+ *mailboxes* :key #'mailbox.thread))))))))
+
+(defimplementation thread-id (thread)
+ thread)
+
+(defimplementation find-thread (thread)
+ (if (thread-alive-p thread)
+ thread))
+
+(defimplementation thread-alive-p (thread)
+ (if (threads:thread-handle thread) t nil))
+
+(defimplementation current-thread ()
+ cormanlisp:*current-thread-id*)
+
+;; XXX implement it
+(defimplementation all-threads ()
+ '())
+
+;; XXX something here is broken
+(defimplementation kill-thread (thread)
+ (threads:terminate-thread thread 'killed))
+
+(defun mailbox (thread)
+ (with-lock *mailbox-lock*
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+(defimplementation send (thread message)
+ (let ((mbox (mailbox thread)))
+ (with-lock (mailbox.lock mbox)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message))))))
+
+(defimplementation receive ()
+ (let ((mbox (mailbox cormanlisp:*current-thread-id*)))
+ (loop
+ (with-lock (mailbox.lock mbox)
+ (when (mailbox.queue mbox)
+ (return (pop (mailbox.queue mbox)))))
+ (sleep 0.1))))
+
+
+;;; This is probably not good, but it WFM
+(in-package :common-lisp)
+
+(defvar *old-documentation* #'documentation)
+(defun documentation (thing &optional (type 'function))
+ (if (symbolp thing)
+ (funcall *old-documentation* thing type)
+ (values)))
+
+(defmethod print-object ((restart restart) stream)
+ (if (or *print-escape*
+ *print-readably*)
+ (print-unreadable-object (restart stream :type t :identity t)
+ (princ (restart-name restart) stream))
+ (when (functionp (restart-report-function restart))
+ (funcall (restart-report-function restart) stream))))
diff --git a/vim/bundle/slimv/slime/swank/ecl.lisp b/vim/bundle/slimv/slime/swank/ecl.lisp
new file mode 100644
index 0000000..2d19c64
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/ecl.lisp
@@ -0,0 +1,845 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-ecl.lisp --- SLIME backend for ECL.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+;;; Administrivia
+
+(defpackage swank/ecl
+ (:use cl swank/backend))
+
+(in-package swank/ecl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun ecl-version ()
+ (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
+ (if version
+ (symbol-value version)
+ 0)))
+ (when (< (ecl-version) 100301)
+ (error "~&IMPORTANT:~% ~
+ The version of ECL you're using (~A) is too old.~% ~
+ Please upgrade to at least 10.3.1.~% ~
+ Sorry for the inconvenience.~%~%"
+ (lisp-implementation-version))))
+
+;; Hard dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'sockets))
+
+;; Soft dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (probe-file "sys:profile.fas")
+ (require :profile)
+ (pushnew :profile *features*))
+ (when (probe-file "sys:serve-event.fas")
+ (require :serve-event)
+ (pushnew :serve-event *features*)))
+
+(declaim (optimize (debug 3)))
+
+;;; Swank-mop
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import-swank-mop-symbols
+ :clos
+ (and (< (ecl-version) 121201)
+ `(:eql-specializer
+ :eql-specializer-object
+ :generic-function-declarations
+ :specializer-direct-methods
+ ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes)
+ '(:compute-applicable-methods-using-classes))))))
+
+(defimplementation gray-package-name ()
+ "GRAY")
+
+
+;;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ ;; While ECL does provide threads, some parts of it are not
+ ;; thread-safe (2010-02-23), including the compiler and CLOS.
+ nil
+ ;; ECL on Windows does not provide condition-variables
+ ;; (or #+(and threads (not windows)) :spawn
+ ;; nil)
+ )
+
+(defun resolve-hostname (name)
+ (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port &key backlog)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket (resolve-hostname host) 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-bsd-sockets:socket-close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format
+ buffering timeout)
+ (declare (ignore timeout))
+ (sb-bsd-sockets:socket-make-stream (accept socket)
+ :output t
+ :input t
+ :buffering (ecase buffering
+ ((t) :full)
+ ((nil) :none)
+ (:line :line))
+ :element-type (if external-format
+ 'character
+ '(unsigned-byte 8))
+ :external-format external-format))
+(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 ()))))
+
+(defimplementation socket-fd (socket)
+ (etypecase socket
+ (fixnum socket)
+ (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
+ (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
+ (file-stream (si:file-stream-fd socket))))
+
+(defvar *external-format-to-coding-system*
+ '((:latin-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")))
+
+(defun external-format (coding-system)
+ (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*))
+ (find coding-system (ext:all-encodings) :test #'string-equal)))
+
+(defimplementation find-external-format (coding-system)
+ #+unicode (external-format coding-system)
+ ;; Without unicode support, ECL uses the one-byte encoding of the
+ ;; underlying OS, and will barf on anything except :DEFAULT. We
+ ;; return NIL here for known multibyte encodings, so
+ ;; SWANK:CREATE-SERVER will barf.
+ #-unicode (let ((xf (external-format coding-system)))
+ (if (member xf '(:utf-8))
+ nil
+ :default)))
+
+
+;;;; Unix Integration
+
+;;; If ECL is built with thread support, it'll spawn a helper thread
+;;; executing the SIGINT handler. We do not want to BREAK into that
+;;; helper but into the main thread, though. This is coupled with the
+;;; current choice of NIL as communication-style in so far as ECL's
+;;; main-thread is also the Slime's REPL thread.
+
+(defimplementation call-with-user-break-handler (real-handler function)
+ (let ((old-handler #'si:terminal-interrupt))
+ (setf (symbol-function 'si:terminal-interrupt)
+ (make-interrupt-handler real-handler))
+ (unwind-protect (funcall function)
+ (setf (symbol-function 'si:terminal-interrupt) old-handler))))
+
+#+threads
+(defun make-interrupt-handler (real-handler)
+ (let ((main-thread (find 'si:top-level (mp:all-processes)
+ :key #'mp:process-name)))
+ #'(lambda (&rest args)
+ (declare (ignore args))
+ (mp:interrupt-process main-thread real-handler))))
+
+#-threads
+(defun make-interrupt-handler (real-handler)
+ #'(lambda (&rest args)
+ (declare (ignore args))
+ (funcall real-handler)))
+
+
+(defimplementation getpid ()
+ (si:getpid))
+
+(defimplementation set-default-directory (directory)
+ (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (ext:getcwd)))
+
+(defimplementation quit-lisp ()
+ (ext:quit))
+
+
+
+;;; Instead of busy waiting with communication-style NIL, use select()
+;;; on the sockets' streams.
+#+serve-event
+(progn
+ (defun poll-streams (streams timeout)
+ (let* ((serve-event::*descriptor-handlers*
+ (copy-list serve-event::*descriptor-handlers*))
+ (active-fds '())
+ (fd-stream-alist
+ (loop for s in streams
+ for fd = (socket-fd s)
+ collect (cons fd s)
+ do (serve-event:add-fd-handler fd :input
+ #'(lambda (fd)
+ (push fd active-fds))))))
+ (serve-event:serve-event timeout)
+ (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))
+
+ (defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (cond ((check-slime-interrupts) (return :interrupt))
+ (timeout (return (poll-streams streams 0)))
+ (t
+ (when-let (ready (poll-streams streams 0.2))
+ (return ready))))))
+
+) ; #+serve-event (progn ...
+
+#-serve-event
+(defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (cond ((check-slime-interrupts) (return :interrupt))
+ (timeout (return (remove-if-not #'listen streams)))
+ (t
+ (let ((ready (remove-if-not #'listen streams)))
+ (if ready (return ready))
+ (sleep 0.1))))))
+
+
+;;;; Compilation
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+
+(defun signal-compiler-condition (&rest args)
+ (apply #'signal 'compiler-condition args))
+
+#-ecl-bytecmp
+(defun handle-compiler-message (condition)
+ ;; ECL emits lots of noise in compiler-notes, like "Invoking
+ ;; external command".
+ (unless (typep condition 'c::compiler-note)
+ (signal-compiler-condition
+ :original-condition condition
+ :message (princ-to-string condition)
+ :severity (etypecase condition
+ (c:compiler-fatal-error :error)
+ (c:compiler-error :error)
+ (error :error)
+ (style-warning :style-warning)
+ (warning :warning))
+ :location (condition-location condition))))
+
+#-ecl-bytecmp
+(defun condition-location (condition)
+ (let ((file (c:compiler-message-file condition))
+ (position (c:compiler-message-file-position condition)))
+ (if (and position (not (minusp position)))
+ (if *buffer-name*
+ (make-buffer-location *buffer-name*
+ *buffer-start-position*
+ position)
+ (make-file-location file position))
+ (make-error-location "No location found."))))
+
+(defimplementation call-with-compilation-hooks (function)
+ #+ecl-bytecmp
+ (funcall function)
+ #-ecl-bytecmp
+ (handler-bind ((c:compiler-message #'handle-compiler-message))
+ (funcall function)))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (compile-file input-file :output-file output-file
+ :load load-p
+ :external-format external-format)))
+
+(defvar *tmpfile-map* (make-hash-table :test #'equal))
+
+(defun note-buffer-tmpfile (tmp-file buffer-name)
+ ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
+ (let ((tmp-namestring (namestring (truename tmp-file))))
+ (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
+ tmp-namestring))
+
+(defun tmpfile-to-buffer (tmp-file)
+ (gethash tmp-file *tmpfile-map*))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer) ; for compilation hooks
+ (*buffer-start-position* position))
+ (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-"))
+ (fasl-file)
+ (warnings-p)
+ (failure-p))
+ (unwind-protect
+ (with-open-file (tmp-stream tmp-file :direction :output
+ :if-exists :supersede)
+ (write-string string tmp-stream)
+ (finish-output tmp-stream)
+ (multiple-value-setq (fasl-file warnings-p failure-p)
+ (compile-file tmp-file
+ :load t
+ :source-truename (or filename
+ (note-buffer-tmpfile tmp-file buffer))
+ :source-offset (1- position))))
+ (when (probe-file tmp-file)
+ (delete-file tmp-file))
+ (when fasl-file
+ (delete-file fasl-file)))
+ (not failure-p)))))
+
+;;;; Documentation
+
+(defimplementation arglist (name)
+ (multiple-value-bind (arglist foundp)
+ (ext:function-lambda-list name)
+ (if foundp arglist :not-available)))
+
+(defimplementation function-name (f)
+ (typecase f
+ (generic-function (clos:generic-function-name f))
+ (function (si:compiled-function-name f))))
+
+;; FIXME
+;; (defimplementation macroexpand-all (form &optional env)
+;; (declare (ignore env))
+
+(defimplementation collect-macro-forms (form &optional env)
+ ;; Currently detects only normal macros, not compiler macros.
+ (declare (ignore env))
+ (with-collected-macro-forms (macro-forms)
+ (handler-bind ((warning #'muffle-warning))
+ (ignore-errors
+ (compile nil `(lambda () ,form))))
+ (values macro-forms nil)))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((frob (type boundp)
+ (when (funcall boundp symbol)
+ (let ((doc (describe-definition symbol type)))
+ (setf result (list* type doc result))))))
+ (frob :VARIABLE #'boundp)
+ (frob :FUNCTION #'fboundp)
+ (frob :CLASS (lambda (x) (find-class x nil))))
+ result))
+
+(defimplementation describe-definition (name type)
+ (case type
+ (:variable (documentation name 'variable))
+ (:function (documentation name 'function))
+ (:class (documentation name 'class))
+ (t nil)))
+
+(defimplementation type-specifier-p (symbol)
+ (or (subtypep nil symbol)
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+
+;;; Debugging
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (import
+ '(si::*break-env*
+ si::*ihs-top*
+ si::*ihs-current*
+ si::*ihs-base*
+ si::*frs-base*
+ si::*frs-top*
+ si::*tpl-commands*
+ si::*tpl-level*
+ si::frs-top
+ si::ihs-top
+ si::ihs-fun
+ si::ihs-env
+ si::sch-frs-base
+ si::set-break-env
+ si::set-current-ihs
+ si::tpl-commands)))
+
+(defun make-invoke-debugger-hook (hook)
+ (when hook
+ #'(lambda (condition old-hook)
+ ;; Regard *debugger-hook* if set by user.
+ (if *debugger-hook*
+ nil ; decline, *DEBUGGER-HOOK* will be tried next.
+ (funcall hook condition old-hook)))))
+
+(defimplementation install-debugger-globally (function)
+ (setq *debugger-hook* function)
+ (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
+ (funcall fun)))
+
+(defvar *backtrace* '())
+
+;;; Commented out; it's not clear this is a good way of doing it. In
+;;; particular because it makes errors stemming from this file harder
+;;; to debug, and given the "young" age of ECL's swank backend, that's
+;;; a bad idea.
+
+;; (defun in-swank-package-p (x)
+;; (and
+;; (symbolp x)
+;; (member (symbol-package x)
+;; (list #.(find-package :swank)
+;; #.(find-package :swank/backend)
+;; #.(ignore-errors (find-package :swank-mop))
+;; #.(ignore-errors (find-package :swank-loader))))
+;; t))
+
+;; (defun is-swank-source-p (name)
+;; (setf name (pathname name))
+;; (pathname-match-p
+;; name
+;; (make-pathname :defaults swank-loader::*source-directory*
+;; :name (pathname-name name)
+;; :type (pathname-type name)
+;; :version (pathname-version name))))
+
+;; (defun is-ignorable-fun-p (x)
+;; (or
+;; (in-swank-package-p (frame-name x))
+;; (multiple-value-bind (file position)
+;; (ignore-errors (si::bc-file (car x)))
+;; (declare (ignore position))
+;; (if file (is-swank-source-p file)))))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (declare (type function debugger-loop-fn))
+ (let* ((*ihs-top* (ihs-top))
+ (*ihs-current* *ihs-top*)
+ (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
+ (*frs-top* (frs-top))
+ (*tpl-level* (1+ *tpl-level*))
+ (*backtrace* (loop for ihs from 0 below *ihs-top*
+ collect (list (si::ihs-fun ihs)
+ (si::ihs-env ihs)
+ nil))))
+ (declare (special *ihs-current*))
+ (loop for f from *frs-base* until *frs-top*
+ do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
+ (when (plusp i)
+ (let* ((x (elt *backtrace* i))
+ (name (si::frs-tag f)))
+ (unless (si::fixnump name)
+ (push name (third x)))))))
+ (setf *backtrace* (nreverse *backtrace*))
+ (set-break-env)
+ (set-current-ihs)
+ (let ((*ihs-base* *ihs-top*))
+ (funcall debugger-loop-fn))))
+
+(defimplementation compute-backtrace (start end)
+ (subseq *backtrace* start
+ (and (numberp end)
+ (min end (length *backtrace*)))))
+
+(defun frame-name (frame)
+ (let ((x (first frame)))
+ (if (symbolp x)
+ x
+ (function-name x))))
+
+(defun function-position (fun)
+ (multiple-value-bind (file position)
+ (si::bc-file fun)
+ (when file
+ (make-file-location file position))))
+
+(defun frame-function (frame)
+ (let* ((x (first frame))
+ fun position)
+ (etypecase x
+ (symbol (and (fboundp x)
+ (setf fun (fdefinition x)
+ position (function-position fun))))
+ (function (setf fun x position (function-position x))))
+ (values fun position)))
+
+(defun frame-decode-env (frame)
+ (let ((functions '())
+ (blocks '())
+ (variables '()))
+ (setf frame (si::decode-ihs-env (second frame)))
+ (dolist (record (remove-if-not #'consp frame))
+ (let* ((record0 (car record))
+ (record1 (cdr record)))
+ (cond ((or (symbolp record0) (stringp record0))
+ (setq variables (acons record0 record1 variables)))
+ ((not (si::fixnump record0))
+ (push record1 functions))
+ ((symbolp record1)
+ (push record1 blocks))
+ (t
+ ))))
+ (values functions blocks variables)))
+
+(defimplementation print-frame (frame stream)
+ (format stream "~A" (first frame)))
+
+(defimplementation frame-source-location (frame-number)
+ (nth-value 1 (frame-function (elt *backtrace* frame-number))))
+
+(defimplementation frame-catch-tags (frame-number)
+ (third (elt *backtrace* frame-number)))
+
+(defimplementation frame-locals (frame-number)
+ (loop for (name . value) in (nth-value 2 (frame-decode-env
+ (elt *backtrace* frame-number)))
+ collect (list :name name :id 0 :value value)))
+
+(defimplementation frame-var-value (frame-number var-number)
+ (destructuring-bind (name . value)
+ (elt
+ (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
+ var-number)
+ (declare (ignore name))
+ value))
+
+(defimplementation disassemble-frame (frame-number)
+ (let ((fun (frame-function (elt *backtrace* frame-number))))
+ (disassemble fun)))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((env (second (elt *backtrace* frame-number))))
+ (si:eval-with-env form env)))
+
+(defimplementation gdb-initial-commands ()
+ ;; These signals are used by the GC.
+ #+linux '("handle SIGPWR noprint nostop"
+ "handle SIGXCPU noprint nostop"))
+
+(defimplementation command-line-args ()
+ (loop for n from 0 below (si:argc) collect (si:argv n)))
+
+
+;;;; Inspector
+
+;;; FIXME: Would be nice if it was possible to inspect objects
+;;; implemented in C.
+
+
+;;;; Definitions
+
+(defvar +TAGS+ (namestring
+ (merge-pathnames "TAGS" (translate-logical-pathname "SYS:"))))
+
+(defun make-file-location (file file-position)
+ ;; File positions in CL start at 0, but Emacs' buffer positions
+ ;; start at 1. We specify (:ALIGN T) because the positions comming
+ ;; from ECL point at right after the toplevel form appearing before
+ ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
+ (make-location `(:file ,(namestring (translate-logical-pathname file)))
+ `(:position ,(1+ file-position))
+ `(:align t)))
+
+(defun make-buffer-location (buffer-name start-position &optional (offset 0))
+ (make-location `(:buffer ,buffer-name)
+ `(:offset ,start-position ,offset)
+ `(:align t)))
+
+(defun make-TAGS-location (&rest tags)
+ (make-location `(:etags-file ,+TAGS+)
+ `(:tag ,@tags)))
+
+(defimplementation find-definitions (name)
+ (let ((annotations (ext:get-annotation name 'si::location :all)))
+ (cond (annotations
+ (loop for annotation in annotations
+ collect (destructuring-bind (dspec file . pos) annotation
+ `(,dspec ,(make-file-location file pos)))))
+ (t
+ (mapcan #'(lambda (type) (find-definitions-by-type name type))
+ (classify-definition-name name))))))
+
+(defun classify-definition-name (name)
+ (let ((types '()))
+ (when (fboundp name)
+ (cond ((special-operator-p name)
+ (push :special-operator types))
+ ((macro-function name)
+ (push :macro types))
+ ((typep (fdefinition name) 'generic-function)
+ (push :generic-function types))
+ ((si:mangle-name name t)
+ (push :c-function types))
+ (t
+ (push :lisp-function types))))
+ (when (boundp name)
+ (cond ((constantp name)
+ (push :constant types))
+ (t
+ (push :global-variable types))))
+ types))
+
+(defun find-definitions-by-type (name type)
+ (ecase type
+ (:lisp-function
+ (when-let (loc (source-location (fdefinition name)))
+ (list `((defun ,name) ,loc))))
+ (:c-function
+ (when-let (loc (source-location (fdefinition name)))
+ (list `((c-source ,name) ,loc))))
+ (:generic-function
+ (loop for method in (clos:generic-function-methods (fdefinition name))
+ for specs = (clos:method-specializers method)
+ for loc = (source-location method)
+ when loc
+ collect `((defmethod ,name ,specs) ,loc)))
+ (:macro
+ (when-let (loc (source-location (macro-function name)))
+ (list `((defmacro ,name) ,loc))))
+ (:constant
+ (when-let (loc (source-location name))
+ (list `((defconstant ,name) ,loc))))
+ (:global-variable
+ (when-let (loc (source-location name))
+ (list `((defvar ,name) ,loc))))
+ (:special-operator)))
+
+;;; FIXME: There ought to be a better way.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun c-function-name-p (name)
+ (and (symbolp name) (si:mangle-name name t) t))
+ (defun c-function-p (object)
+ (and (functionp object)
+ (let ((fn-name (function-name object)))
+ (and fn-name (c-function-name-p fn-name))))))
+
+(deftype c-function ()
+ `(satisfies c-function-p))
+
+(defun assert-source-directory ()
+ (unless (probe-file #P"SRC:")
+ (error "ECL's source directory ~A does not exist. ~
+ You can specify a different location via the environment ~
+ variable `ECLSRCDIR'."
+ (namestring (translate-logical-pathname #P"SYS:")))))
+
+(defun assert-TAGS-file ()
+ (unless (probe-file +TAGS+)
+ (error "No TAGS file ~A found. It should have been installed with ECL."
+ +TAGS+)))
+
+(defun package-names (package)
+ (cons (package-name package) (package-nicknames package)))
+
+(defun source-location (object)
+ (converting-errors-to-error-location
+ (typecase object
+ (c-function
+ (assert-source-directory)
+ (assert-TAGS-file)
+ (let ((lisp-name (function-name object)))
+ (assert lisp-name)
+ (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t)
+ (assert flag)
+ ;; In ECL's code base sometimes the mangled name is used
+ ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or
+ ;; @EXT::SYMBOL is used. We cannot predict here, so we just
+ ;; provide several candidates.
+ (apply #'make-TAGS-location
+ c-name
+ (loop with s = (symbol-name lisp-name)
+ for p in (package-names (symbol-package lisp-name))
+ collect (format nil "~A::~A" p s)
+ collect (format nil "~(~A::~A~)" p s))))))
+ (function
+ (multiple-value-bind (file pos) (ext:compiled-function-file object)
+ (cond ((not file)
+ (return-from source-location nil))
+ ((tmpfile-to-buffer file)
+ (make-buffer-location (tmpfile-to-buffer file) pos))
+ (t
+ (assert (probe-file file))
+ (assert (not (minusp pos)))
+ (make-file-location file pos)))))
+ (method
+ ;; FIXME: This will always return NIL at the moment; ECL does not
+ ;; store debug information for methods yet.
+ (source-location (clos:method-function object)))
+ ((member nil t)
+ (multiple-value-bind (flag c-name) (si:mangle-name object)
+ (assert flag)
+ (make-TAGS-location c-name))))))
+
+(defimplementation find-source-location (object)
+ (or (source-location object)
+ (make-error-location "Source definition of ~S not found." object)))
+
+
+;;;; Profiling
+
+#+profile
+(progn
+
+(defimplementation profile (fname)
+ (when fname (eval `(profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+ (when fname (eval `(profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+ (profile:unprofile-all)
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (profile:report))
+
+(defimplementation profile-reset ()
+ (profile:reset)
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ (profile:profile))
+
+(defimplementation profile-package (package callers methods)
+ (declare (ignore callers methods))
+ (eval `(profile:profile ,(package-name (find-package package)))))
+) ; #+profile (progn ...
+
+
+;;;; Threads
+
+#+threads
+(progn
+ (defvar *thread-id-counter* 0)
+
+ (defparameter *thread-id-map* (make-hash-table))
+
+ (defvar *thread-id-map-lock*
+ (mp:make-lock :name "thread id map lock"))
+
+ (defimplementation spawn (fn &key name)
+ (mp:process-run-function name fn))
+
+ (defimplementation thread-id (target-thread)
+ (block thread-id
+ (mp:with-lock (*thread-id-map-lock*)
+ ;; Does TARGET-THREAD have an id already?
+ (maphash (lambda (id thread-pointer)
+ (let ((thread (si:weak-pointer-value thread-pointer)))
+ (cond ((not thread)
+ (remhash id *thread-id-map*))
+ ((eq thread target-thread)
+ (return-from thread-id id)))))
+ *thread-id-map*)
+ ;; TARGET-THREAD not found in *THREAD-ID-MAP*
+ (let ((id (incf *thread-id-counter*))
+ (thread-pointer (si:make-weak-pointer target-thread)))
+ (setf (gethash id *thread-id-map*) thread-pointer)
+ id))))
+
+ (defimplementation find-thread (id)
+ (mp:with-lock (*thread-id-map-lock*)
+ (let* ((thread-ptr (gethash id *thread-id-map*))
+ (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
+ (unless thread
+ (remhash id *thread-id-map*))
+ thread)))
+
+ (defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+ (defimplementation thread-status (thread)
+ (if (mp:process-active-p thread)
+ "RUNNING"
+ "STOPPED"))
+
+ (defimplementation make-lock (&key name)
+ (mp:make-lock :name name :recursive t))
+
+ (defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (mp:with-lock (lock) (funcall function)))
+
+ (defimplementation current-thread ()
+ mp:*current-process*)
+
+ (defimplementation all-threads ()
+ (mp:all-processes))
+
+ (defimplementation interrupt-thread (thread fn)
+ (mp:interrupt-process thread fn))
+
+ (defimplementation kill-thread (thread)
+ (mp:process-kill thread))
+
+ (defimplementation thread-alive-p (thread)
+ (mp:process-active-p thread))
+
+ (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
+ (defvar *mailboxes* (list))
+ (declaim (type list *mailboxes*))
+
+ (defstruct (mailbox (:conc-name mailbox.))
+ thread
+ (mutex (mp:make-lock))
+ (cvar (mp:make-condition-variable))
+ (queue '() :type list))
+
+ (defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-lock (*mailbox-lock*)
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+ (defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+ (mp:with-lock (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
+
+ (defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox (current-thread)))
+ (mutex (mailbox.mutex mbox)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (mp:with-lock (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)))
+ (mp:condition-variable-timedwait (mailbox.cvar mbox)
+ mutex
+ 0.2)))))
+
+ ) ; #+threads (progn ...
diff --git a/vim/bundle/slimv/slime/swank/gray.lisp b/vim/bundle/slimv/slime/swank/gray.lisp
new file mode 100644
index 0000000..b910a78
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/gray.lisp
@@ -0,0 +1,170 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; swank-gray.lisp --- Gray stream based IO redirection.
+;;;
+;;; Created 2003
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(in-package swank/backend)
+
+#.(progn
+ (defvar *gray-stream-symbols*
+ '(fundamental-character-output-stream
+ stream-write-char
+ stream-write-string
+ stream-fresh-line
+ stream-force-output
+ stream-finish-output
+
+ fundamental-character-input-stream
+ stream-read-char
+ stream-peek-char
+ stream-read-line
+ stream-listen
+ stream-unread-char
+ stream-clear-input
+ stream-line-column
+ stream-read-char-no-hang))
+ nil)
+
+(defpackage swank/gray
+ (:use cl swank/backend)
+ (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)
+ (:export . #.*gray-stream-symbols*))
+
+(in-package swank/gray)
+
+(defclass slime-output-stream (fundamental-character-output-stream)
+ ((output-fn :initarg :output-fn)
+ (buffer :initform (make-string 8000))
+ (fill-pointer :initform 0)
+ (column :initform 0)
+ (lock :initform (make-lock :name "buffer write lock"))))
+
+(defmacro with-slime-output-stream (stream &body body)
+ `(with-slots (lock output-fn buffer fill-pointer column) ,stream
+ (call-with-lock-held lock (lambda () ,@body))))
+
+(defmethod stream-write-char ((stream slime-output-stream) char)
+ (with-slime-output-stream stream
+ (setf (schar buffer fill-pointer) char)
+ (incf fill-pointer)
+ (incf column)
+ (when (char= #\newline char)
+ (setf column 0))
+ (when (= fill-pointer (length buffer))
+ (finish-output stream)))
+ char)
+
+(defmethod stream-write-string ((stream slime-output-stream) string
+ &optional start end)
+ (with-slime-output-stream stream
+ (let* ((start (or start 0))
+ (end (or end (length string)))
+ (len (length buffer))
+ (count (- end start))
+ (free (- len fill-pointer)))
+ (when (>= count free)
+ (stream-finish-output stream))
+ (cond ((< count len)
+ (replace buffer string :start1 fill-pointer
+ :start2 start :end2 end)
+ (incf fill-pointer count))
+ (t
+ (funcall output-fn (subseq string start end))))
+ (let ((last-newline (position #\newline string :from-end t
+ :start start :end end)))
+ (setf column (if last-newline
+ (- end last-newline 1)
+ (+ column count))))))
+ string)
+
+(defmethod stream-line-column ((stream slime-output-stream))
+ (with-slime-output-stream stream column))
+
+(defmethod stream-finish-output ((stream slime-output-stream))
+ (with-slime-output-stream stream
+ (unless (zerop fill-pointer)
+ (funcall output-fn (subseq buffer 0 fill-pointer))
+ (setf fill-pointer 0)))
+ nil)
+
+(defmethod stream-force-output ((stream slime-output-stream))
+ (stream-finish-output stream))
+
+(defmethod stream-fresh-line ((stream slime-output-stream))
+ (with-slime-output-stream stream
+ (cond ((zerop column) nil)
+ (t (terpri stream) t))))
+
+(defclass slime-input-stream (fundamental-character-input-stream)
+ ((input-fn :initarg :input-fn)
+ (buffer :initform "") (index :initform 0)
+ (lock :initform (make-lock :name "buffer read lock"))))
+
+(defmethod stream-read-char ((s slime-input-stream))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index input-fn) s
+ (when (= index (length buffer))
+ (let ((string (funcall input-fn)))
+ (cond ((zerop (length string))
+ (return-from stream-read-char :eof))
+ (t
+ (setf buffer string)
+ (setf index 0)))))
+ (assert (plusp (length buffer)))
+ (prog1 (aref buffer index) (incf index))))))
+
+(defmethod stream-listen ((s slime-input-stream))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (< index (length buffer))))))
+
+(defmethod stream-unread-char ((s slime-input-stream) char)
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (decf index)
+ (cond ((eql (aref buffer index) char)
+ (setf (aref buffer index) char))
+ (t
+ (warn "stream-unread-char: ignoring ~S (expected ~S)"
+ char (aref buffer index)))))))
+ nil)
+
+(defmethod stream-clear-input ((s slime-input-stream))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (setf buffer ""
+ index 0))))
+ nil)
+
+(defmethod stream-line-column ((s slime-input-stream))
+ nil)
+
+(defmethod stream-read-char-no-hang ((s slime-input-stream))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (when (< index (length buffer))
+ (prog1 (aref buffer index) (incf index)))))))
+
+
+;;;
+
+(defimplementation make-output-stream (write-string)
+ (make-instance 'slime-output-stream :output-fn write-string))
+
+(defimplementation make-input-stream (read-string)
+ (make-instance 'slime-input-stream :input-fn read-string))
diff --git a/vim/bundle/slimv/slime/swank/lispworks.lisp b/vim/bundle/slimv/slime/swank/lispworks.lisp
new file mode 100644
index 0000000..d4b656e
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/lispworks.lisp
@@ -0,0 +1,1018 @@
+;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
+;;;
+;;; Created 2003, Helmut Eller
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(defpackage swank/lispworks
+ (:use cl swank/backend))
+
+(in-package swank/lispworks)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "comm"))
+
+(defimplementation gray-package-name ()
+ "STREAM")
+
+(import-swank-mop-symbols :clos '(:slot-definition-documentation
+ :slot-boundp-using-class
+ :slot-value-using-class
+ :slot-makunbound-using-class
+ :eql-specializer
+ :eql-specializer-object
+ :compute-applicable-methods-using-classes))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (documentation slot t))
+
+(defun swank-mop:slot-boundp-using-class (class object slotd)
+ (clos:slot-boundp-using-class class object
+ (clos:slot-definition-name slotd)))
+
+(defun swank-mop:slot-value-using-class (class object slotd)
+ (clos:slot-value-using-class class object
+ (clos:slot-definition-name slotd)))
+
+(defun (setf swank-mop:slot-value-using-class) (value class object slotd)
+ (setf (clos:slot-value-using-class class object
+ (clos:slot-definition-name slotd))
+ value))
+
+(defun swank-mop:slot-makunbound-using-class (class object slotd)
+ (clos:slot-makunbound-using-class class object
+ (clos:slot-definition-name slotd)))
+
+(defun swank-mop:compute-applicable-methods-using-classes (gf classes)
+ (clos::compute-applicable-methods-from-classes gf classes))
+
+;; lispworks doesn't have the eql-specializer class, it represents
+;; them as a list of `(EQL ,OBJECT)
+(deftype swank-mop:eql-specializer () 'cons)
+
+(defun swank-mop:eql-specializer-object (eql-spec)
+ (second eql-spec))
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+ (defvar *original-defimplementation* (macro-function 'defimplementation))
+ (defmacro defimplementation (&whole whole name args &body body
+ &environment env)
+ (declare (ignore args body))
+ `(progn
+ (dspec:record-definition '(defun ,name) (dspec:location)
+ :check-redefinition-p nil)
+ ,(funcall *original-defimplementation* whole env))))
+
+;;; UTF8
+
+(defimplementation string-to-utf8 (string)
+ (ef:encode-lisp-string string '(:utf-8 :eol-style :lf)))
+
+(defimplementation utf8-to-string (octets)
+ (ef:decode-external-string octets '(:utf-8 :eol-style :lf)))
+
+;;; TCP server
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defun socket-fd (socket)
+ (etypecase socket
+ (fixnum socket)
+ (comm:socket-stream (comm:socket-stream-socket socket))))
+
+(defimplementation create-socket (host port &key backlog)
+ (multiple-value-bind (socket where errno)
+ #-(or lispworks4.1 (and macosx lispworks4.3))
+ (comm::create-tcp-socket-for-service port :address host
+ :backlog (or backlog 5))
+ #+(or lispworks4.1 (and macosx lispworks4.3))
+ (comm::create-tcp-socket-for-service port)
+ (cond (socket socket)
+ (t (error 'network-error
+ :format-control "~A failed: ~A (~D)"
+ :format-arguments (list where
+ (list #+unix (lw:get-unix-error errno))
+ errno))))))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (comm:get-socket-address (socket-fd socket))))
+
+(defimplementation close-socket (socket)
+ (comm::close-socket (socket-fd socket)))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (declare (ignore buffering))
+ (let* ((fd (comm::get-fd-from-socket socket)))
+ (assert (/= fd -1))
+ (cond ((not external-format)
+ (make-instance 'comm:socket-stream
+ :socket fd
+ :direction :io
+ :read-timeout timeout
+ :element-type '(unsigned-byte 8)))
+ (t
+ (assert (valid-external-format-p external-format))
+ (ecase (first external-format)
+ ((:latin-1 :ascii)
+ (make-instance 'comm:socket-stream
+ :socket fd
+ :direction :io
+ :read-timeout timeout
+ :element-type 'base-char))
+ (:utf-8
+ (make-flexi-stream
+ (make-instance 'comm:socket-stream
+ :socket fd
+ :direction :io
+ :read-timeout timeout
+ :element-type '(unsigned-byte 8))
+ external-format)))))))
+
+(defun make-flexi-stream (stream external-format)
+ (unless (member :flexi-streams *features*)
+ (error "Cannot use external format ~A~
+ without having installed flexi-streams in the inferior-lisp."
+ external-format))
+ (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
+ stream
+ :external-format
+ (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
+ external-format)))
+
+;;; Coding Systems
+
+(defun valid-external-format-p (external-format)
+ (member external-format *external-format-to-coding-system*
+ :test #'equal :key #'car))
+
+(defvar *external-format-to-coding-system*
+ '(((:latin-1 :eol-style :lf)
+ "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
+ ;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1")
+ ;;((:utf-8) "utf-8")
+ ((:utf-8 :eol-style :lf) "utf-8-unix")
+ ;;((:euc-jp) "euc-jp")
+ ((:euc-jp :eol-style :lf) "euc-jp-unix")
+ ;;((:ascii) "us-ascii")
+ ((:ascii :eol-style :lf) "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+;;; Unix signals
+
+(defun sigint-handler ()
+ (with-simple-restart (continue "Continue from SIGINT handler.")
+ (invoke-debugger "SIGINT")))
+
+(defun make-sigint-handler (process)
+ (lambda (&rest args)
+ (declare (ignore args))
+ (mp:process-interrupt process #'sigint-handler)))
+
+(defun set-sigint-handler ()
+ ;; Set SIGINT handler on Swank request handler thread.
+ #-win32
+ (sys::set-signal-handler +sigint+
+ (make-sigint-handler mp:*current-process*)))
+
+#-win32
+(defimplementation install-sigint-handler (handler)
+ (sys::set-signal-handler +sigint+
+ (let ((self mp:*current-process*))
+ (lambda (&rest args)
+ (declare (ignore args))
+ (mp:process-interrupt self handler)))))
+
+(defimplementation getpid ()
+ #+win32 (win32:get-current-process-id)
+ #-win32 (system::getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "lispworks")
+
+(defimplementation set-default-directory (directory)
+ (namestring (hcl:change-directory directory)))
+
+;;;; Documentation
+
+(defun map-list (function list)
+ "Map over proper and not proper lists."
+ (loop for (car . cdr) on list
+ collect (funcall function car) into result
+ when (null cdr) return result
+ when (atom cdr) return (nconc result (funcall function cdr))))
+
+(defun replace-strings-with-symbols (tree)
+ (map-list
+ (lambda (x)
+ (typecase x
+ (list
+ (replace-strings-with-symbols x))
+ (symbol
+ x)
+ (string
+ (intern x))
+ (t
+ (intern (write-to-string x)))))
+ tree))
+
+(defimplementation arglist (symbol-or-function)
+ (let ((arglist (lw:function-lambda-list symbol-or-function)))
+ (etypecase arglist
+ ((member :dont-know)
+ :not-available)
+ (list
+ (replace-strings-with-symbols arglist)))))
+
+(defimplementation function-name (function)
+ (nth-value 2 (function-lambda-expression function)))
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (walker:walk-form form))
+
+(defun generic-function-p (object)
+ (typep object 'generic-function))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ "Return a plist describing SYMBOL.
+Return NIL if the symbol is unbound."
+ (let ((result '()))
+ (labels ((first-line (string)
+ (let ((pos (position #\newline string)))
+ (if (null pos) string (subseq string 0 pos))))
+ (doc (kind &optional (sym symbol))
+ (let ((string (or (documentation sym kind))))
+ (if string
+ (first-line string)
+ :not-documented)))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :generic-function (if (and (fboundp symbol)
+ (generic-function-p (fdefinition symbol)))
+ (doc 'function)))
+ (maybe-push
+ :function (if (and (fboundp symbol)
+ (not (generic-function-p (fdefinition symbol))))
+ (doc 'function)))
+ (maybe-push
+ :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
+ (if (fboundp setf-name)
+ (doc 'setf))))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(defimplementation describe-definition (symbol type)
+ (ecase type
+ (:variable (describe-symbol symbol))
+ (:class (describe (find-class symbol)))
+ ((:function :generic-function) (describe-function symbol))
+ (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
+
+(defun describe-function (symbol)
+ (cond ((fboundp symbol)
+ (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
+ symbol
+ (lispworks:function-lambda-list symbol)
+ (documentation symbol 'function))
+ (describe (fdefinition symbol)))
+ (t (format t "~S is not fbound" symbol))))
+
+(defun describe-symbol (sym)
+ (format t "~A is a symbol in package ~A." sym (symbol-package sym))
+ (when (boundp sym)
+ (format t "~%~%Value: ~A" (symbol-value sym)))
+ (let ((doc (documentation sym 'variable)))
+ (when doc
+ (format t "~%~%Variable documentation:~%~A" doc)))
+ (when (fboundp sym)
+ (describe-function sym)))
+
+(defimplementation type-specifier-p (symbol)
+ (or (ignore-errors
+ (subtypep nil symbol))
+ (not (eq (type-specifier-arglist symbol) :not-available))))
+
+;;; Debugging
+
+(defclass slime-env (env:environment)
+ ((debugger-hook :initarg :debugger-hoook)))
+
+(defun slime-env (hook io-bindings)
+ (make-instance 'slime-env :name "SLIME Environment"
+ :io-bindings io-bindings
+ :debugger-hoook hook))
+
+(defmethod env-internals:environment-display-notifier
+ ((env slime-env) &key restarts condition)
+ (declare (ignore restarts condition))
+ (swank:swank-debugger-hook condition *debugger-hook*))
+
+(defmethod env-internals:environment-display-debugger ((env slime-env))
+ *debug-io*)
+
+(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
+ (apply #'swank:y-or-n-p-in-emacs msg args))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook))
+ (env:with-environment ((slime-env hook '()))
+ (funcall fun))))
+
+(defimplementation install-debugger-globally (function)
+ (setq *debugger-hook* function)
+ (setf (env:environment) (slime-env function '())))
+
+(defvar *sldb-top-frame*)
+
+(defun interesting-frame-p (frame)
+ (cond ((or (dbg::call-frame-p frame)
+ (dbg::derived-call-frame-p frame)
+ (dbg::foreign-frame-p frame)
+ (dbg::interpreted-call-frame-p frame))
+ t)
+ ((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
+ ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
+ ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
+ ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
+ (t nil)))
+
+(defun nth-next-frame (frame n)
+ "Unwind FRAME N times."
+ (do ((frame frame (dbg::frame-next frame))
+ (i n (if (interesting-frame-p frame) (1- i) i)))
+ ((or (not frame)
+ (and (interesting-frame-p frame) (zerop i)))
+ frame)))
+
+(defun nth-frame (index)
+ (nth-next-frame *sldb-top-frame* index))
+
+(defun find-top-frame ()
+ "Return the most suitable top-frame for the debugger."
+ (flet ((find-named-frame (name)
+ (do ((frame (dbg::debugger-stack-current-frame
+ dbg::*debugger-stack*)
+ (nth-next-frame frame 1)))
+ ((or (null frame) ; no frame found!
+ (and (dbg::call-frame-p frame)
+ (eq (dbg::call-frame-function-name frame)
+ name)))
+ (nth-next-frame frame 1)))))
+ (or (find-named-frame 'invoke-debugger)
+ (find-named-frame 'swank::safe-backtrace)
+ ;; if we can't find a likely top frame, take any old frame
+ ;; at the top
+ (dbg::debugger-stack-current-frame dbg::*debugger-stack*))))
+
+(defimplementation call-with-debugging-environment (fn)
+ (dbg::with-debugger-stack ()
+ (let ((*sldb-top-frame* (find-top-frame)))
+ (funcall fn))))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum))
+ (backtrace '()))
+ (do ((frame (nth-frame start) (dbg::frame-next frame))
+ (i start))
+ ((or (not frame) (= i end)) (nreverse backtrace))
+ (when (interesting-frame-p frame)
+ (incf i)
+ (push frame backtrace)))))
+
+(defun frame-actual-args (frame)
+ (let ((*break-on-signals* nil)
+ (kind nil))
+ (loop for arg in (dbg::call-frame-arglist frame)
+ if (eq kind '&rest)
+ nconc (handler-case
+ (dbg::dbg-eval arg frame)
+ (error (e) (list (format nil "<~A>" arg))))
+ and do (loop-finish)
+ else
+ if (member arg '(&rest &optional &key))
+ do (setq kind arg)
+ else
+ nconc
+ (handler-case
+ (nconc (and (eq kind '&key)
+ (list (cond ((symbolp arg)
+ (intern (symbol-name arg) :keyword))
+ ((and (consp arg) (symbolp (car arg)))
+ (intern (symbol-name (car arg))
+ :keyword))
+ (t (caar arg)))))
+ (list (dbg::dbg-eval
+ (cond ((symbolp arg) arg)
+ ((and (consp arg) (symbolp (car arg)))
+ (car arg))
+ (t (cadar arg)))
+ frame)))
+ (error (e) (list (format nil "<~A>" arg)))))))
+
+(defimplementation print-frame (frame stream)
+ (cond ((dbg::call-frame-p frame)
+ (prin1 (cons (dbg::call-frame-function-name frame)
+ (frame-actual-args frame))
+ stream))
+ (t (princ frame stream))))
+
+(defun frame-vars (frame)
+ (first (dbg::frame-locals-format-list frame #'list 75 0)))
+
+(defimplementation frame-locals (n)
+ (let ((frame (nth-frame n)))
+ (if (dbg::call-frame-p frame)
+ (mapcar (lambda (var)
+ (destructuring-bind (name value symbol location) var
+ (declare (ignore name location))
+ (list :name symbol :id 0
+ :value value)))
+ (frame-vars frame)))))
+
+(defimplementation frame-var-value (frame var)
+ (let ((frame (nth-frame frame)))
+ (destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
+ (declare (ignore _n _s _l))
+ value)))
+
+(defimplementation frame-source-location (frame)
+ (let ((frame (nth-frame frame))
+ (callee (if (plusp frame) (nth-frame (1- frame)))))
+ (if (dbg::call-frame-p frame)
+ (let ((dspec (dbg::call-frame-function-name frame))
+ (cname (and (dbg::call-frame-p callee)
+ (dbg::call-frame-function-name callee)))
+ (path (and (dbg::call-frame-p frame)
+ (dbg::call-frame-edit-path frame))))
+ (if dspec
+ (frame-location dspec cname path))))))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (dbg::dbg-eval form frame)))
+
+(defun function-name-package (name)
+ (typecase name
+ (null nil)
+ (symbol (symbol-package name))
+ ((cons (eql hcl:subfunction))
+ (destructuring-bind (name parent) (cdr name)
+ (declare (ignore name))
+ (function-name-package parent)))
+ ((cons (eql lw:top-level-form)) nil)
+ (t nil)))
+
+(defimplementation frame-package (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (if (dbg::call-frame-p frame)
+ (function-name-package (dbg::call-frame-function-name frame)))))
+
+(defimplementation return-from-frame (frame-number form)
+ (let* ((frame (nth-frame frame-number))
+ (return-frame (dbg::find-frame-for-return frame)))
+ (dbg::dbg-return-from-call-frame frame form return-frame
+ dbg::*debugger-stack*)))
+
+(defimplementation restart-frame (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (dbg::restart-frame frame :same-args t)))
+
+(defimplementation disassemble-frame (frame-number)
+ (let* ((frame (nth-frame frame-number)))
+ (when (dbg::call-frame-p frame)
+ (let ((function (dbg::get-call-frame-function frame)))
+ (disassemble function)))))
+
+;;; Definition finding
+
+(defun frame-location (dspec callee-name edit-path)
+ (let ((infos (dspec:find-dspec-locations dspec)))
+ (cond (infos
+ (destructuring-bind ((rdspec location) &rest _) infos
+ (declare (ignore _))
+ (let ((name (and callee-name (symbolp callee-name)
+ (string callee-name)))
+ (path (edit-path-to-cmucl-source-path edit-path)))
+ (make-dspec-location rdspec location
+ `(:call-site ,name :edit-path ,path)))))
+ (t
+ (list :error (format nil "Source location not available for: ~S"
+ dspec))))))
+
+;; dbg::call-frame-edit-path is not documented but lets assume the
+;; binary representation of the integer EDIT-PATH should be
+;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the
+;; same as cadadddr. Something is odd with the highest bit.
+(defun edit-path-to-cmucl-source-path (edit-path)
+ (and edit-path
+ (cons 0
+ (let ((n -1))
+ (loop for i from (1- (integer-length edit-path)) downto 0
+ if (logbitp i edit-path) do (incf n)
+ else collect (prog1 n (setq n 0)))))))
+
+;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1)
+
+(defimplementation find-definitions (name)
+ (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
+ (loop for (dspec location) in locations
+ collect (list dspec (make-dspec-location dspec location)))))
+
+
+;;; Compilation
+
+(defmacro with-swank-compilation-unit ((location &rest options) &body body)
+ (lw:rebinding (location)
+ `(let ((compiler::*error-database* '()))
+ (with-compilation-unit ,options
+ (multiple-value-prog1 (progn ,@body)
+ (signal-error-data-base compiler::*error-database*
+ ,location)
+ (signal-undefined-functions compiler::*unknown-functions*
+ ,location))))))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (with-swank-compilation-unit (input-file)
+ (compile-file input-file
+ :output-file output-file
+ :load load-p
+ :external-format external-format)))
+
+(defvar *within-call-with-compilation-hooks* nil
+ "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
+
+(defvar *undefined-functions-hash* nil
+ "Hash table to map info about undefined functions to pathnames.")
+
+(lw:defadvice (compile-file compile-file-and-collect-notes :around)
+ (pathname &rest rest)
+ (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
+ (when *within-call-with-compilation-hooks*
+ (maphash (lambda (unfun dspecs)
+ (dolist (dspec dspecs)
+ (let ((unfun-info (list unfun dspec)))
+ (unless (gethash unfun-info *undefined-functions-hash*)
+ (setf (gethash unfun-info *undefined-functions-hash*)
+ pathname)))))
+ compiler::*unknown-functions*))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (let ((compiler::*error-database* '())
+ (*undefined-functions-hash* (make-hash-table :test 'equal))
+ (*within-call-with-compilation-hooks* t))
+ (with-compilation-unit ()
+ (prog1 (funcall function)
+ (signal-error-data-base compiler::*error-database*)
+ (signal-undefined-functions compiler::*unknown-functions*)))))
+
+(defun map-error-database (database fn)
+ (loop for (filename . defs) in database do
+ (loop for (dspec . conditions) in defs do
+ (dolist (c conditions)
+ (multiple-value-bind (condition path)
+ (if (consp c) (values (car c) (cdr c)) (values c nil))
+ (funcall fn filename dspec condition path))))))
+
+(defun lispworks-severity (condition)
+ (cond ((not condition) :warning)
+ (t (etypecase condition
+ #-(or lispworks4 lispworks5)
+ (conditions:compiler-note :note)
+ (error :error)
+ (style-warning :warning)
+ (warning :warning)))))
+
+(defun signal-compiler-condition (message location condition)
+ (check-type message string)
+ (signal
+ (make-instance 'compiler-condition :message message
+ :severity (lispworks-severity condition)
+ :location location
+ :original-condition condition)))
+
+(defvar *temp-file-format* '(:utf-8 :eol-style :lf))
+
+(defun compile-from-temp-file (string filename)
+ (unwind-protect
+ (progn
+ (with-open-file (s filename :direction :output
+ :if-exists :supersede
+ :external-format *temp-file-format*)
+
+ (write-string string s)
+ (finish-output s))
+ (multiple-value-bind (binary-filename warnings? failure?)
+ (compile-file filename :load t
+ :external-format *temp-file-format*)
+ (declare (ignore warnings?))
+ (when binary-filename
+ (delete-file binary-filename))
+ (not failure?)))
+ (delete-file filename)))
+
+(defun dspec-function-name-position (dspec fallback)
+ (etypecase dspec
+ (cons (let ((name (dspec:dspec-primary-name dspec)))
+ (typecase name
+ ((or symbol string)
+ (list :function-name (string name)))
+ (t fallback))))
+ (null fallback)
+ (symbol (list :function-name (string dspec)))))
+
+(defmacro with-fairly-standard-io-syntax (&body body)
+ "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
+ (let ((package (gensym))
+ (readtable (gensym)))
+ `(let ((,package *package*)
+ (,readtable *readtable*))
+ (with-standard-io-syntax
+ (let ((*package* ,package)
+ (*readtable* ,readtable))
+ ,@body)))))
+
+(defun skip-comments (stream)
+ (let ((pos0 (file-position stream)))
+ (cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
+ '(()))
+ (file-position stream (1- (file-position stream))))
+ (t (file-position stream pos0)))))
+
+#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
+(defun dspec-stream-position (stream dspec)
+ (with-fairly-standard-io-syntax
+ (loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
+ (form (read stream nil '#1=#:eof)))
+ (when (eq form '#1#)
+ (return nil))
+ (labels ((check-dspec (form)
+ (when (consp form)
+ (let ((operator (car form)))
+ (case operator
+ ((progn)
+ (mapcar #'check-dspec
+ (cdr form)))
+ ((eval-when locally macrolet symbol-macrolet)
+ (mapcar #'check-dspec
+ (cddr form)))
+ ((in-package)
+ (let ((package (find-package (second form))))
+ (when package
+ (setq *package* package))))
+ (otherwise
+ (let ((form-dspec (dspec:parse-form-dspec form)))
+ (when (dspec:dspec-equal dspec form-dspec)
+ (return pos)))))))))
+ (check-dspec form))))))
+
+(defun dspec-file-position (file dspec)
+ (let* ((*compile-file-pathname* (pathname file))
+ (*compile-file-truename* (truename *compile-file-pathname*))
+ (*load-pathname* *compile-file-pathname*)
+ (*load-truename* *compile-file-truename*))
+ (with-open-file (stream file)
+ (let ((pos
+ #-(or lispworks4.1 lispworks4.2)
+ (ignore-errors (dspec-stream-position stream dspec))))
+ (if pos
+ (list :position (1+ pos))
+ (dspec-function-name-position dspec `(:position 1)))))))
+
+(defun emacs-buffer-location-p (location)
+ (and (consp location)
+ (eq (car location) :emacs-buffer)))
+
+(defun make-dspec-location (dspec location &optional hints)
+ (etypecase location
+ ((or pathname string)
+ (multiple-value-bind (file err)
+ (ignore-errors (namestring (truename location)))
+ (if err
+ (list :error (princ-to-string err))
+ (make-location `(:file ,file)
+ (dspec-file-position file dspec)
+ hints))))
+ (symbol
+ `(:error ,(format nil "Cannot resolve location: ~S" location)))
+ ((satisfies emacs-buffer-location-p)
+ (destructuring-bind (_ buffer offset) location
+ (declare (ignore _))
+ (make-location `(:buffer ,buffer)
+ (dspec-function-name-position dspec `(:offset ,offset 0))
+ hints)))))
+
+(defun make-dspec-progenitor-location (dspec location edit-path)
+ (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
+ (make-dspec-location
+ (if canon-dspec
+ (if (dspec:local-dspec-p canon-dspec)
+ (dspec:dspec-progenitor canon-dspec)
+ canon-dspec)
+ nil)
+ location
+ (if edit-path
+ (list :edit-path (edit-path-to-cmucl-source-path edit-path))))))
+
+(defun signal-error-data-base (database &optional location)
+ (map-error-database
+ database
+ (lambda (filename dspec condition edit-path)
+ (signal-compiler-condition
+ (format nil "~A" condition)
+ (make-dspec-progenitor-location dspec (or location filename) edit-path)
+ condition))))
+
+(defun unmangle-unfun (symbol)
+ "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
+function names like \(SETF GET)."
+ (cond ((sys::setf-symbol-p symbol)
+ (sys::setf-pair-from-underlying-name symbol))
+ (t symbol)))
+
+(defun signal-undefined-functions (htab &optional filename)
+ (maphash (lambda (unfun dspecs)
+ (dolist (dspec dspecs)
+ (signal-compiler-condition
+ (format nil "Undefined function ~A" (unmangle-unfun unfun))
+ (make-dspec-progenitor-location
+ dspec
+ (or filename
+ (gethash (list unfun dspec) *undefined-functions-hash*))
+ nil)
+ nil)))
+ htab))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore filename policy))
+ (assert buffer)
+ (assert position)
+ (let* ((location (list :emacs-buffer buffer position))
+ (tmpname (hcl:make-temp-file nil "lisp")))
+ (with-swank-compilation-unit (location)
+ (compile-from-temp-file
+ (with-output-to-string (s)
+ (let ((*print-radix* t))
+ (print `(eval-when (:compile-toplevel)
+ (setq dspec::*location* (list ,@location)))
+ s))
+ (write-string string s))
+ tmpname))))
+
+;;; xref
+
+(defmacro defxref (name function)
+ `(defimplementation ,name (name)
+ (xref-results (,function name))))
+
+(defxref who-calls hcl:who-calls)
+(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
+(defxref calls-who hcl:calls-who)
+(defxref list-callers list-callers-internal)
+(defxref list-callees list-callees-internal)
+
+(defun list-callers-internal (name)
+ (let ((callers (make-array 100
+ :fill-pointer 0
+ :adjustable t)))
+ (hcl:sweep-all-objects
+ #'(lambda (object)
+ (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
+ #+Harlequin-Unix-Lisp (sys:callablep object)
+ #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp)
+ (sys:compiled-code-p object)
+ (system::find-constant$funcallable name object))
+ (vector-push-extend object callers))))
+ ;; Delay dspec:object-dspec until after sweep-all-objects
+ ;; to reduce allocation problems.
+ (loop for object across callers
+ collect (if (symbolp object)
+ (list 'function object)
+ (or (dspec:object-dspec object) object)))))
+
+(defun list-callees-internal (name)
+ (let ((callees '()))
+ (system::find-constant$funcallable
+ 'junk name
+ :test #'(lambda (junk constant)
+ (declare (ignore junk))
+ (when (and (symbolp constant)
+ (fboundp constant))
+ (pushnew (list 'function constant) callees :test 'equal))
+ ;; Return nil so we iterate over all constants.
+ nil))
+ callees))
+
+;; only for lispworks 4.2 and above
+#-lispworks4.1
+(progn
+ (defxref who-references hcl:who-references)
+ (defxref who-binds hcl:who-binds)
+ (defxref who-sets hcl:who-sets))
+
+(defimplementation who-specializes (classname)
+ (let ((methods (clos:class-direct-methods (find-class classname))))
+ (xref-results (mapcar #'dspec:object-dspec methods))))
+
+(defun xref-results (dspecs)
+ (flet ((frob-locs (dspec locs)
+ (cond (locs
+ (loop for (name loc) in locs
+ collect (list name (make-dspec-location name loc))))
+ (t `((,dspec (:error "Source location not available")))))))
+ (loop for dspec in dspecs
+ append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
+
+;;; Inspector
+
+(defmethod emacs-inspect ((o t))
+ (lispworks-inspect o))
+
+(defmethod emacs-inspect ((o function))
+ (lispworks-inspect o))
+
+;; FIXME: slot-boundp-using-class in LW works with names so we can't
+;; use our method in swank.lisp.
+(defmethod emacs-inspect ((o standard-object))
+ (lispworks-inspect o))
+
+(defun lispworks-inspect (o)
+ (multiple-value-bind (names values _getter _setter type)
+ (lw:get-inspector-values o nil)
+ (declare (ignore _getter _setter))
+ (append
+ (label-value-line "Type" type)
+ (loop for name in names
+ for value in values
+ append (label-value-line name value)))))
+
+;;; Miscellaneous
+
+(defimplementation quit-lisp ()
+ (lispworks:quit))
+
+;;; Tracing
+
+(defun parse-fspec (fspec)
+ "Return a dspec for FSPEC."
+ (ecase (car fspec)
+ ((:defmethod) `(method ,(cdr fspec)))))
+
+(defun tracedp (dspec)
+ (member dspec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (dspec)
+ (cond ((tracedp dspec)
+ (eval `(untrace ,dspec))
+ (format nil "~S is now untraced." dspec))
+ (t
+ (eval `(trace (,dspec)))
+ (format nil "~S is now traced." dspec))))
+
+(defimplementation toggle-trace (fspec)
+ (toggle-trace-aux (parse-fspec fspec)))
+
+;;; Multithreading
+
+(defimplementation initialize-multiprocessing (continuation)
+ (cond ((not mp::*multiprocessing*)
+ (push (list "Initialize SLIME" '() continuation)
+ mp:*initial-processes*)
+ (mp:initialize-multiprocessing))
+ (t (funcall continuation))))
+
+(defimplementation spawn (fn &key name)
+ (mp:process-run-function name () fn))
+
+(defvar *id-lock* (mp:make-lock))
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (mp:with-lock (*id-lock*)
+ (or (getf (mp:process-plist thread) 'id)
+ (setf (getf (mp:process-plist thread) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (find id (mp:list-all-processes)
+ :key (lambda (p) (getf (mp:process-plist p) 'id))))
+
+(defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+(defimplementation thread-status (thread)
+ (format nil "~A ~D"
+ (mp:process-whostate thread)
+ (mp:process-priority thread)))
+
+(defimplementation make-lock (&key name)
+ (mp:make-lock :name name))
+
+(defimplementation call-with-lock-held (lock function)
+ (mp:with-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ mp:*current-process*)
+
+(defimplementation all-threads ()
+ (mp:list-all-processes))
+
+(defimplementation interrupt-thread (thread fn)
+ (mp:process-interrupt thread fn))
+
+(defimplementation kill-thread (thread)
+ (mp:process-kill thread))
+
+(defimplementation thread-alive-p (thread)
+ (mp:process-alive-p thread))
+
+(defstruct (mailbox (:conc-name mailbox.))
+ (mutex (mp:make-lock :name "thread mailbox"))
+ (queue '() :type list))
+
+(defvar *mailbox-lock* (mp:make-lock))
+
+(defun mailbox (thread)
+ (mp:with-lock (*mailbox-lock*)
+ (or (getf (mp:process-plist thread) 'mailbox)
+ (setf (getf (mp:process-plist thread) 'mailbox)
+ (make-mailbox)))))
+
+(defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox mp:*current-process*))
+ (lock (mailbox.mutex mbox)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (mp:with-lock (lock "receive-if/try")
+ (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)))
+ (mp:process-wait-with-timeout
+ "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
+
+(defimplementation send (thread message)
+ (let ((mbox (mailbox thread)))
+ (mp:with-lock ((mailbox.mutex mbox))
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message))))))
+
+(let ((alist '())
+ (lock (mp:make-lock :name "register-thread")))
+
+ (defimplementation register-thread (name thread)
+ (declare (type symbol name))
+ (mp:with-lock (lock)
+ (etypecase thread
+ (null
+ (setf alist (delete name alist :key #'car)))
+ (mp:process
+ (let ((probe (assoc name alist)))
+ (cond (probe (setf (cdr probe) thread))
+ (t (setf alist (acons name thread alist))))))))
+ nil)
+
+ (defimplementation find-registered (name)
+ (mp:with-lock (lock)
+ (cdr (assoc name alist)))))
+
+
+(defimplementation set-default-initial-binding (var form)
+ (setq mp:*process-initial-bindings*
+ (acons var `(eval (quote ,form))
+ mp:*process-initial-bindings* )))
+
+(defimplementation thread-attributes (thread)
+ (list :priority (mp:process-priority thread)
+ :idle (mp:process-idle-time thread)))
+
+
+;;;; Weak hashtables
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-kind :key args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ (apply #'make-hash-table :weak-kind :value args))
diff --git a/vim/bundle/slimv/slime/swank/match.lisp b/vim/bundle/slimv/slime/swank/match.lisp
new file mode 100644
index 0000000..d6200db
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/match.lisp
@@ -0,0 +1,242 @@
+;;
+;; SELECT-MATCH macro (and IN macro)
+;;
+;; Copyright 1990 Stephen Adams
+;;
+;; You are free to copy, distribute and make derivative works of this
+;; source provided that this copyright notice is displayed near the
+;; beginning of the file. No liability is accepted for the
+;; correctness or performance of the code. If you modify the code
+;; please indicate this fact both at the place of modification and in
+;; this copyright message.
+;;
+;; Stephen Adams
+;; Department of Electronics and Computer Science
+;; University of Southampton
+;; SO9 5NH, UK
+;;
+;; sra@ecs.soton.ac.uk
+;;
+
+;;
+;; Synopsis:
+;;
+;; (select-match expression
+;; (pattern action+)*)
+;;
+;; --- or ---
+;;
+;; (select-match expression
+;; pattern => expression
+;; pattern => expression
+;; ...)
+;;
+;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1)
+;; | symbol ;matches anything
+;; | 'anything ;must be EQUAL
+;; | (pattern = pattern) ;both patterns must match
+;; | (#'function pattern) ;predicate test
+;; | (pattern . pattern) ;cons cell
+;;
+
+;; Example
+;;
+;; (select-match item
+;; (('if e1 e2 e3) 'if-then-else) ;(1)
+;; ((#'oddp k) 'an-odd-integer) ;(2)
+;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3)
+;; (other 'anything-else)) ;(4)
+;;
+;; Notes
+;;
+;; . Each pattern is tested in turn. The first match is taken.
+;;
+;; . If no pattern matches, an error is signalled.
+;;
+;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e.
+;; numbers, strings, characters, etc.) match things which are EQUAL.
+;;
+;; . Quoted patterns (which are CONSTANTP) are constants.
+;;
+;; . Symbols match anything. The symbol is bound to the matched item
+;; for the execution of the actions.
+;; For example, (SELECT-MATCH '(1 2 3)
+;; (1 . X) => X)
+;; returns (2 3) because X is bound to the cdr of the candidate.
+;;
+;; . The two pattern match (p1 = p2) can be used to name parts
+;; of the matched structure. For example, (ALL = (HD . TL))
+;; matches a cons cell. ALL is bound to the cons cell, HD to its car
+;; and TL to its tail.
+;;
+;; . A predicate test applies the predicate to the item being matched.
+;; If the predicate returns NIL then the match fails.
+;; If it returns truth, then the nested pattern is matched. This is
+;; often just a symbol like K in the example.
+;;
+;; . Care should be taken with the domain values for predicate matches.
+;; If, in the above eg, item is not an integer, an error would occur
+;; during the test. A safer pattern would be
+;; (#'integerp (#'oddp k))
+;; This would only test for oddness of the item was an integer.
+;;
+;; . A single symbol will match anything so it can be used as a default
+;; case, like OTHER above.
+;;
+
+(in-package swank/match)
+
+(defmacro match (expression &body patterns)
+ `(select-match ,expression ,@patterns))
+
+(defmacro select-match (expression &rest patterns)
+ (let* ((do-let (not (atom expression)))
+ (key (if do-let (gensym) expression))
+ (cbody (expand-select-patterns key patterns))
+ (cform `(cond . ,cbody)))
+ (if do-let
+ `(let ((,key ,expression)) ,cform)
+ cform)))
+
+(defun expand-select-patterns (key patterns)
+ (if (eq (second patterns) '=>)
+ (expand-select-patterns-style-2 key patterns)
+ (expand-select-patterns-style-1 key patterns)))
+
+(defun expand-select-patterns-style-1 (key patterns)
+ (if (null patterns)
+ `((t (error "Case select pattern match failure on ~S" ,key)))
+ (let* ((pattern (caar patterns))
+ (actions (cdar patterns))
+ (rest (cdr patterns))
+ (test (compile-select-test key pattern))
+ (bindings (compile-select-bindings key pattern actions)))
+ `(,(if bindings `(,test (let ,bindings . ,actions))
+ `(,test . ,actions))
+ . ,(unless (eq test t)
+ (expand-select-patterns-style-1 key rest))))))
+
+(defun expand-select-patterns-style-2 (key patterns)
+ (cond ((null patterns)
+ `((t (error "Case select pattern match failure on ~S" ,key))))
+ (t (when (or (< (length patterns) 3)
+ (not (eq (second patterns) '=>)))
+ (error "Illegal patterns: ~S" patterns))
+ (let* ((pattern (first patterns))
+ (actions (list (third patterns)))
+ (rest (cdddr patterns))
+ (test (compile-select-test key pattern))
+ (bindings (compile-select-bindings key pattern actions)))
+ `(,(if bindings `(,test (let ,bindings . ,actions))
+ `(,test . ,actions))
+ . ,(unless (eq test t)
+ (expand-select-patterns-style-2 key rest)))))))
+
+(defun compile-select-test (key pattern)
+ (let ((tests (remove t (compile-select-tests key pattern))))
+ (cond
+ ;; note AND does this anyway, but this allows us to tell if
+ ;; the pattern will always match.
+ ((null tests) t)
+ ((= (length tests) 1) (car tests))
+ (t `(and . ,tests)))))
+
+(defun compile-select-tests (key pattern)
+ (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql)
+ ((symbolp pattern) 'eq)
+ (t 'equal))
+ ,key ,pattern)))
+ ((symbolp pattern) '(t))
+ ((select-double-match? pattern)
+ (append
+ (compile-select-tests key (first pattern))
+ (compile-select-tests key (third pattern))))
+ ((select-predicate? pattern)
+ (append
+ `((,(second (first pattern)) ,key))
+ (compile-select-tests key (second pattern))))
+ ((consp pattern)
+ (append
+ `((consp ,key))
+ (compile-select-tests (cs-car key) (car
+ pattern))
+ (compile-select-tests (cs-cdr key) (cdr
+ pattern))))
+ (t (error "Illegal select pattern: ~S" pattern))))
+
+
+(defun compile-select-bindings (key pattern action)
+ (cond ((constantp pattern) '())
+ ((symbolp pattern)
+ (if (select-in-tree pattern action)
+ `((,pattern ,key))
+ '()))
+ ((select-double-match? pattern)
+ (append
+ (compile-select-bindings key (first pattern) action)
+ (compile-select-bindings key (third pattern) action)))
+ ((select-predicate? pattern)
+ (compile-select-bindings key (second pattern) action))
+ ((consp pattern)
+ (append
+ (compile-select-bindings (cs-car key) (car pattern)
+ action)
+ (compile-select-bindings (cs-cdr key) (cdr pattern)
+ action)))))
+
+(defun select-in-tree (atom tree)
+ (or (eq atom tree)
+ (if (consp tree)
+ (or (select-in-tree atom (car tree))
+ (select-in-tree atom (cdr tree))))))
+
+(defun select-double-match? (pattern)
+ ;; (<pattern> = <pattern>)
+ (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
+ (null (cdddr pattern))
+ (eq (second pattern) '=)))
+
+(defun select-predicate? (pattern)
+ ;; ((function <f>) <pattern>)
+ (and (consp pattern)
+ (consp (cdr pattern))
+ (null (cddr pattern))
+ (consp (first pattern))
+ (consp (cdr (first pattern)))
+ (null (cddr (first pattern)))
+ (eq (caar pattern) 'function)))
+
+(defun cs-car (exp)
+ (cs-car/cdr 'car exp
+ '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr)
+ (cdar . cadar) (cddr . caddr)
+ (caaar . caaaar) (caadr . caaadr) (cadar . caadar)
+ (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr)
+ (cddar . caddar) (cdddr . cadddr))))
+
+(defun cs-cdr (exp)
+ (cs-car/cdr 'cdr exp
+ '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr)
+ (cdar . cddar) (cddr . cdddr)
+ (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar)
+ (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr)
+ (cddar . cdddar) (cdddr . cddddr))))
+
+(defun cs-car/cdr (op exp table)
+ (if (and (consp exp) (= (length exp) 2))
+ (let ((replacement (assoc (car exp) table)))
+ (if replacement
+ `(,(cdr replacement) ,(second exp))
+ `(,op ,exp)))
+ `(,op ,exp)))
+
+;; (setf c1 '(select-match x (a 1) (b 2 3 4)))
+;; (setf c2 '(select-match (car y)
+;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+
+;; else))))
+;; (setf c3 '(select-match (caddr y)
+;; ((all = (x y)) (list x y all))
+;; ((a '= b) (list 'assign a b))
+;; ((#'oddp k) (1+ k)))))
+
+
diff --git a/vim/bundle/slimv/slime/swank/mkcl.lisp b/vim/bundle/slimv/slime/swank/mkcl.lisp
new file mode 100644
index 0000000..53696fb
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/mkcl.lisp
@@ -0,0 +1,933 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-mkcl.lisp --- SLIME backend for MKCL.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+;;; Administrivia
+
+(defpackage swank/mkcl
+ (:use cl swank/backend))
+
+(in-package swank/mkcl)
+
+;;(declaim (optimize (debug 3)))
+
+(defvar *tmp*)
+
+(defimplementation gray-package-name ()
+ '#:gray)
+
+(eval-when (:compile-toplevel :load-toplevel)
+
+ (swank/backend::import-swank-mop-symbols :clos
+ ;; '(:eql-specializer
+ ;; :eql-specializer-object
+ ;; :generic-function-declarations
+ ;; :specializer-direct-methods
+ ;; :compute-applicable-methods-using-classes)
+ nil
+ ))
+
+
+;;; UTF8
+
+(defimplementation string-to-utf8 (string)
+ (mkcl:octets (si:utf-8 string)))
+
+(defimplementation utf8-to-string (octets)
+ (string (si:utf-8 octets)))
+
+
+;;;; TCP Server
+
+(eval-when (:compile-toplevel :load-toplevel)
+ ;; At compile-time we need access to the sb-bsd-sockets package for the
+ ;; the following code to be read properly.
+ ;; It is a bit a shame we have to load the entire module to get that.
+ (require 'sockets))
+
+
+(defun resolve-hostname (name)
+ (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port &key backlog)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket (resolve-hostname host) 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-bsd-sockets:socket-close socket))
+
+(defun accept (socket)
+ "Like socket-accept, but retry on EINTR."
+ (loop (handler-case
+ (return (sb-bsd-sockets:socket-accept socket))
+ (sb-bsd-sockets:interrupted-error ()))))
+
+(defimplementation accept-connection (socket
+ &key external-format
+ buffering timeout)
+ (declare (ignore timeout))
+ (sb-bsd-sockets:socket-make-stream (accept socket)
+ :output t ;; bogus
+ :input t ;; bogus
+ :buffering buffering ;; bogus
+ :element-type (if external-format
+ 'character
+ '(unsigned-byte 8))
+ :external-format external-format
+ ))
+
+(defimplementation preferred-communication-style ()
+ :spawn
+ )
+
+(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")))
+
+(defun external-format (coding-system)
+ (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*))
+ (find coding-system (si:all-encodings) :test #'string-equal)))
+
+(defimplementation find-external-format (coding-system)
+ #+unicode (external-format coding-system)
+ ;; Without unicode support, MKCL uses the one-byte encoding of the
+ ;; underlying OS, and will barf on anything except :DEFAULT. We
+ ;; return NIL here for known multibyte encodings, so
+ ;; SWANK:CREATE-SERVER will barf.
+ #-unicode (let ((xf (external-format coding-system)))
+ (if (member xf '(:utf-8))
+ nil
+ :default)))
+
+
+
+;;;; Unix signals
+
+(defimplementation install-sigint-handler (handler)
+ (let ((old-handler (symbol-function 'si:terminal-interrupt)))
+ (setf (symbol-function 'si:terminal-interrupt)
+ (if (consp handler)
+ (car handler)
+ (lambda (&rest args)
+ (declare (ignore args))
+ (funcall handler)
+ (continue))))
+ (list old-handler)))
+
+
+(defimplementation getpid ()
+ (mkcl:getpid))
+
+(defimplementation set-default-directory (directory)
+ (mk-ext::chdir (namestring directory))
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (mk-ext:getcwd)))
+
+(defmacro progf (plist &rest forms)
+ `(let (_vars _vals)
+ (do ((p ,plist (cddr p)))
+ ((endp p))
+ (push (car p) _vars)
+ (push (cadr p) _vals))
+ (progv _vars _vals ,@forms)
+ )
+ )
+
+(defvar *inferior-lisp-sleeping-post* nil)
+
+(defimplementation quit-lisp ()
+ (progf (ignore-errors (eval (read-from-string "swank::*saved-global-streams*"))) ;; restore original IO streams.
+ (when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*))
+ ;;(mk-ext:quit :verbose t)
+ ))
+
+
+;;;; Compilation
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename*)
+
+(defun signal-compiler-condition (&rest args)
+ (signal (apply #'make-condition 'compiler-condition args)))
+
+#|
+(defun handle-compiler-warning (condition)
+ (signal-compiler-condition
+ :original-condition condition
+ :message (format nil "~A" condition)
+ :severity :warning
+ :location
+ (if *buffer-name*
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* 0))
+ ;; ;; compiler::*current-form*
+ ;; (if compiler::*current-function*
+ ;; (make-location (list :file *compile-filename*)
+ ;; (list :function-name
+ ;; (symbol-name
+ ;; (slot-value compiler::*current-function*
+ ;; 'compiler::name))))
+ (list :error "No location found.")
+ ;; )
+ )))
+|#
+
+#|
+(defun condition-location (condition)
+ (let ((file (compiler:compiler-message-file condition))
+ (position (compiler:compiler-message-file-position condition)))
+ (if (and position (not (minusp position)))
+ (if *buffer-name*
+ (make-buffer-location *buffer-name*
+ *buffer-start-position*
+ position)
+ (make-file-location file position))
+ (make-error-location "No location found."))))
+|#
+
+(defun condition-location (condition)
+ (if *buffer-name*
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* 0))
+ ;; ;; compiler::*current-form* ;
+ ;; (if compiler::*current-function* ;
+ ;; (make-location (list :file *compile-filename*) ;
+ ;; (list :function-name ;
+ ;; (symbol-name ;
+ ;; (slot-value compiler::*current-function* ;
+ ;; 'compiler::name)))) ;
+ (if (typep condition 'compiler::compiler-message)
+ (make-location (list :file (namestring (compiler:compiler-message-file condition)))
+ (list :end-position (compiler:compiler-message-file-end-position condition)))
+ (list :error "No location found."))
+ )
+ )
+
+(defun handle-compiler-message (condition)
+ (unless (typep condition 'compiler::compiler-note)
+ (signal-compiler-condition
+ :original-condition condition
+ :message (princ-to-string condition)
+ :severity (etypecase condition
+ (compiler:compiler-fatal-error :error)
+ (compiler:compiler-error :error)
+ (error :error)
+ (style-warning :style-warning)
+ (warning :warning))
+ :location (condition-location condition))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((compiler:compiler-message #'handle-compiler-message))
+ (funcall function)))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (*compile-filename* input-file))
+ (handler-bind (#|
+ (compiler::compiler-note
+ #'(lambda (n)
+ (format t "~%swank saw a compiler note: ~A~%" n) (finish-output) nil))
+ (compiler::compiler-warning
+ #'(lambda (w)
+ (format t "~%swank saw a compiler warning: ~A~%" w) (finish-output) nil))
+ (compiler::compiler-error
+ #'(lambda (e)
+ (format t "~%swank saw a compiler error: ~A~%" e) (finish-output) nil))
+ |#
+ )
+ (multiple-value-bind (output-truename warnings-p failure-p)
+ (compile-file input-file :output-file output-file :external-format external-format)
+ (values output-truename warnings-p
+ (or failure-p
+ (and load-p (not (load output-truename))))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename policy)
+ (declare (ignore filename policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-string* string))
+ (with-input-from-string (s string)
+ (when position (file-position position))
+ (compile-from-stream s)))))
+
+(defun compile-from-stream (stream)
+ (let ((file (mkcl:mkstemp "TMP:MKCL-SWANK-TMPXXXXXX"))
+ output-truename
+ warnings-p
+ failure-p
+ )
+ (with-open-file (s file :direction :output :if-exists :overwrite)
+ (do ((line (read-line stream nil) (read-line stream nil)))
+ ((not line))
+ (write-line line s)))
+ (unwind-protect
+ (progn
+ (multiple-value-setq (output-truename warnings-p failure-p)
+ (compile-file file))
+ (and (not failure-p) (load output-truename)))
+ (when (probe-file file) (delete-file file))
+ (when (probe-file output-truename) (delete-file output-truename)))))
+
+
+;;;; Documentation
+
+(defun grovel-docstring-for-arglist (name type)
+ (flet ((compute-arglist-offset (docstring)
+ (when docstring
+ (let ((pos1 (search "Args: " docstring)))
+ (if pos1
+ (+ pos1 6)
+ (let ((pos2 (search "Syntax: " docstring)))
+ (when pos2
+ (+ pos2 8))))))))
+ (let* ((docstring (si::get-documentation name type))
+ (pos (compute-arglist-offset docstring)))
+ (if pos
+ (multiple-value-bind (arglist errorp)
+ (ignore-errors
+ (values (read-from-string docstring t nil :start pos)))
+ (if (or errorp (not (listp arglist)))
+ :not-available
+ arglist
+ ))
+ :not-available ))))
+
+(defimplementation arglist (name)
+ (cond ((and (symbolp name) (special-operator-p name))
+ (let ((arglist (grovel-docstring-for-arglist name 'function)))
+ (if (consp arglist) (cdr arglist) arglist)))
+ ((and (symbolp name) (macro-function name))
+ (let ((arglist (grovel-docstring-for-arglist name 'function)))
+ (if (consp arglist) (cdr arglist) arglist)))
+ ((or (functionp name) (fboundp name))
+ (multiple-value-bind (name fndef)
+ (if (functionp name)
+ (values (function-name name) name)
+ (values name (fdefinition name)))
+ (let ((fle (function-lambda-expression fndef)))
+ (case (car fle)
+ (si:lambda-block (caddr fle))
+ (t (typecase fndef
+ (generic-function (clos::generic-function-lambda-list fndef))
+ (compiled-function (grovel-docstring-for-arglist name 'function))
+ (function :not-available)))))))
+ (t :not-available)))
+
+(defimplementation function-name (f)
+ (si:compiled-function-name f)
+ )
+
+(eval-when (:compile-toplevel :load-toplevel)
+ ;; At compile-time we need access to the walker package for the
+ ;; the following code to be read properly.
+ ;; It is a bit a shame we have to load the entire module to get that.
+ (require 'walker))
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (walker:macroexpand-all form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (dolist (type '(:VARIABLE :FUNCTION :CLASS))
+ (let ((doc (describe-definition symbol type)))
+ (when doc
+ (setf result (list* type doc result)))))
+ result))
+
+(defimplementation describe-definition (name type)
+ (case type
+ (:variable (documentation name 'variable))
+ (:function (documentation name 'function))
+ (:class (documentation name 'class))
+ (t nil)))
+
+;;; Debugging
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (import
+ '(si::*break-env*
+ si::*ihs-top*
+ si::*ihs-current*
+ si::*ihs-base*
+ si::*frs-base*
+ si::*frs-top*
+ si::*tpl-commands*
+ si::*tpl-level*
+ si::frs-top
+ si::ihs-top
+ si::ihs-fun
+ si::ihs-env
+ si::sch-frs-base
+ si::set-break-env
+ si::set-current-ihs
+ si::tpl-commands)))
+
+(defvar *backtrace* '())
+
+(defun in-swank-package-p (x)
+ (and
+ (symbolp x)
+ (member (symbol-package x)
+ (list #.(find-package :swank)
+ #.(find-package :swank/backend)
+ #.(ignore-errors (find-package :swank-mop))
+ #.(ignore-errors (find-package :swank-loader))))
+ t))
+
+(defun is-swank-source-p (name)
+ (setf name (pathname name))
+ #+(or)
+ (pathname-match-p
+ name
+ (make-pathname :defaults swank-loader::*source-directory*
+ :name (pathname-name name)
+ :type (pathname-type name)
+ :version (pathname-version name)))
+ nil)
+
+(defun is-ignorable-fun-p (x)
+ (or
+ (in-swank-package-p (frame-name x))
+ (multiple-value-bind (file position)
+ (ignore-errors (si::compiled-function-file (car x)))
+ (declare (ignore position))
+ (if file (is-swank-source-p file)))))
+
+(defmacro find-ihs-top (x)
+ (declare (ignore x))
+ '(si::ihs-top))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (declare (type function debugger-loop-fn))
+ (let* (;;(*tpl-commands* si::tpl-commands)
+ (*ihs-base* 0)
+ (*ihs-top* (find-ihs-top 'call-with-debugging-environment))
+ (*ihs-current* *ihs-top*)
+ (*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top))))
+ (*frs-top* (frs-top))
+ (*read-suppress* nil)
+ ;;(*tpl-level* (1+ *tpl-level*))
+ (*backtrace* (loop for ihs from 0 below *ihs-top*
+ collect (list (si::ihs-fun ihs)
+ (si::ihs-env ihs)
+ nil))))
+ (declare (special *ihs-current*))
+ (loop for f from *frs-base* to *frs-top*
+ do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
+ (when (plusp i)
+ (let* ((x (elt *backtrace* i))
+ (name (si::frs-tag f)))
+ (unless (mkcl:fixnump name)
+ (push name (third x)))))))
+ (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
+ (setf *tmp* *backtrace*)
+ (set-break-env)
+ (set-current-ihs)
+ (let ((*ihs-base* *ihs-top*))
+ (funcall debugger-loop-fn))))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook)
+ (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
+ (funcall fun)))
+
+(defimplementation compute-backtrace (start end)
+ (when (numberp end)
+ (setf end (min end (length *backtrace*))))
+ (loop for f in (subseq *backtrace* start end)
+ collect f))
+
+(defimplementation format-sldb-condition (condition)
+ "Format a condition for display in SLDB."
+ ;;(princ-to-string condition)
+ (format nil "~A~%In thread: ~S" condition mt:*thread*)
+ )
+
+(defun frame-name (frame)
+ (let ((x (first frame)))
+ (if (symbolp x)
+ x
+ (function-name x))))
+
+(defun function-position (fun)
+ (multiple-value-bind (file position)
+ (si::compiled-function-file fun)
+ (and file (make-location
+ `(:file ,(if (stringp file) file (namestring file)))
+ ;;`(:position ,position)
+ `(:end-position , position)))))
+
+(defun frame-function (frame)
+ (let* ((x (first frame))
+ fun position)
+ (etypecase x
+ (symbol (and (fboundp x)
+ (setf fun (fdefinition x)
+ position (function-position fun))))
+ (function (setf fun x position (function-position x))))
+ (values fun position)))
+
+(defun frame-decode-env (frame)
+ (let ((functions '())
+ (blocks '())
+ (variables '()))
+ (setf frame (si::decode-ihs-env (second frame)))
+ (dolist (record frame)
+ (let* ((record0 (car record))
+ (record1 (cdr record)))
+ (cond ((or (symbolp record0) (stringp record0))
+ (setq variables (acons record0 record1 variables)))
+ ((not (mkcl:fixnump record0))
+ (push record1 functions))
+ ((symbolp record1)
+ (push record1 blocks))
+ (t
+ ))))
+ (values functions blocks variables)))
+
+(defimplementation print-frame (frame stream)
+ (let ((function (first frame)))
+ (let ((fname
+;;; (cond ((symbolp function) function)
+;;; ((si:instancep function) (slot-value function 'name))
+;;; ((compiled-function-p function)
+;;; (or (si::compiled-function-name function) 'lambda))
+;;; (t :zombi))
+ (si::get-fname function)
+ ))
+ (if (eq fname 'si::bytecode)
+ (format stream "~A [Evaluation of: ~S]"
+ fname (function-lambda-expression function))
+ (format stream "~A" fname)
+ )
+ (when (si::closurep function)
+ (format stream
+ ", closure generated from ~A"
+ (si::get-fname (si:closure-producer function)))
+ )
+ )
+ )
+ )
+
+(defimplementation frame-source-location (frame-number)
+ (nth-value 1 (frame-function (elt *backtrace* frame-number))))
+
+(defimplementation frame-catch-tags (frame-number)
+ (third (elt *backtrace* frame-number)))
+
+(defimplementation frame-locals (frame-number)
+ (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
+ with i = 0
+ collect (list :name name :id (prog1 i (incf i)) :value value)))
+
+(defimplementation frame-var-value (frame-number var-id)
+ (cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id)))
+
+(defimplementation disassemble-frame (frame-number)
+ (let ((fun (frame-fun (elt *backtrace* frame-number))))
+ (disassemble fun)))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((env (second (elt *backtrace* frame-number))))
+ (si:eval-in-env form env)))
+
+#|
+(defimplementation gdb-initial-commands ()
+ ;; These signals are used by the GC.
+ #+linux '("handle SIGPWR noprint nostop"
+ "handle SIGXCPU noprint nostop"))
+
+(defimplementation command-line-args ()
+ (loop for n from 0 below (si:argc) collect (si:argv n)))
+|#
+
+;;;; Inspector
+
+(defmethod emacs-inspect ((o t))
+ ; ecl clos support leaves some to be desired
+ (cond
+ ((streamp o)
+ (list*
+ (format nil "~S is an ordinary stream~%" o)
+ (append
+ (list
+ "Open for "
+ (cond
+ ((ignore-errors (interactive-stream-p o)) "Interactive")
+ ((and (input-stream-p o) (output-stream-p o)) "Input and output")
+ ((input-stream-p o) "Input")
+ ((output-stream-p o) "Output"))
+ `(:newline) `(:newline))
+ (label-value-line*
+ ("Element type" (stream-element-type o))
+ ("External format" (stream-external-format o)))
+ (ignore-errors (label-value-line*
+ ("Broadcast streams" (broadcast-stream-streams o))))
+ (ignore-errors (label-value-line*
+ ("Concatenated streams" (concatenated-stream-streams o))))
+ (ignore-errors (label-value-line*
+ ("Echo input stream" (echo-stream-input-stream o))))
+ (ignore-errors (label-value-line*
+ ("Echo output stream" (echo-stream-output-stream o))))
+ (ignore-errors (label-value-line*
+ ("Output String" (get-output-stream-string o))))
+ (ignore-errors (label-value-line*
+ ("Synonym symbol" (synonym-stream-symbol o))))
+ (ignore-errors (label-value-line*
+ ("Input stream" (two-way-stream-input-stream o))))
+ (ignore-errors (label-value-line*
+ ("Output stream" (two-way-stream-output-stream o)))))))
+ ((si:instancep o) ;;t
+ (let* ((cl (si:instance-class o))
+ (slots (clos::class-slots cl)))
+ (list* (format nil "~S is an instance of class ~A~%"
+ o (clos::class-name cl))
+ (loop for x in slots append
+ (let* ((name (clos::slot-definition-name x))
+ (value (if (slot-boundp o name)
+ (clos::slot-value o name)
+ "Unbound"
+ )))
+ (list
+ (format nil "~S: " name)
+ `(:value ,value)
+ `(:newline)))))))
+ (t (list (format nil "~A" o)))))
+
+;;;; Definitions
+
+(defimplementation find-definitions (name)
+ (if (fboundp name)
+ (let ((tmp (find-source-location (symbol-function name))))
+ `(((defun ,name) ,tmp)))))
+
+(defimplementation find-source-location (obj)
+ (setf *tmp* obj)
+ (or
+ (typecase obj
+ (function
+ (multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj))
+ (if (and file pos)
+ (make-location
+ `(:file ,(if (stringp file) file (namestring file)))
+ `(:end-position ,pos) ;; `(:position ,pos)
+ `(:snippet
+ ,(with-open-file (s file)
+ (file-position s pos)
+ (skip-comments-and-whitespace s)
+ (read-snippet s))))))))
+ `(:error (format nil "Source definition of ~S not found" obj))))
+
+;;;; Profiling
+
+
+(eval-when (:compile-toplevel :load-toplevel)
+ ;; At compile-time we need access to the profile package for the
+ ;; the following code to be read properly.
+ ;; It is a bit a shame we have to load the entire module to get that.
+ (require 'profile))
+
+
+(defimplementation profile (fname)
+ (when fname (eval `(profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+ (when fname (eval `(profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+ (profile:unprofile-all)
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (profile:report))
+
+(defimplementation profile-reset ()
+ (profile:reset)
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ (profile:profile))
+
+(defimplementation profile-package (package callers methods)
+ (declare (ignore callers methods))
+ (eval `(profile:profile ,(package-name (find-package package)))))
+
+
+;;;; Threads
+
+(defvar *thread-id-counter* 0)
+
+(defvar *thread-id-counter-lock*
+ (mt:make-lock :name "thread id counter lock"))
+
+(defun next-thread-id ()
+ (mt:with-lock (*thread-id-counter-lock*)
+ (incf *thread-id-counter*))
+ )
+
+(defparameter *thread-id-map* (make-hash-table))
+(defparameter *id-thread-map* (make-hash-table))
+
+(defvar *thread-id-map-lock*
+ (mt:make-lock :name "thread id map lock"))
+
+(defparameter +default-thread-local-variables+
+ '(*macroexpand-hook*
+ *default-pathname-defaults*
+ *readtable*
+ *random-state*
+ *compile-print*
+ *compile-verbose*
+ *load-print*
+ *load-verbose*
+ *print-array*
+ *print-base*
+ *print-case*
+ *print-circle*
+ *print-escape*
+ *print-gensym*
+ *print-length*
+ *print-level*
+ *print-lines*
+ *print-miser-width*
+ *print-pprint-dispatch*
+ *print-pretty*
+ *print-radix*
+ *print-readably*
+ *print-right-margin*
+ *read-base*
+ *read-default-float-format*
+ *read-eval*
+ *read-suppress*
+ ))
+
+(defun thread-local-default-bindings ()
+ (let (local)
+ (dolist (var +default-thread-local-variables+ local)
+ (setq local (acons var (symbol-value var) local))
+ )))
+
+;; mkcl doesn't have weak pointers
+(defimplementation spawn (fn &key name initial-bindings)
+ (let* ((local-defaults (thread-local-default-bindings))
+ (thread
+ ;;(mt:make-thread :name name)
+ (mt:make-thread :name name
+ :initial-bindings (nconc initial-bindings
+ local-defaults))
+ )
+ (id (next-thread-id)))
+ (mt:with-lock (*thread-id-map-lock*)
+ (setf (gethash id *thread-id-map*) thread)
+ (setf (gethash thread *id-thread-map*) id))
+ (mt:thread-preset
+ thread
+ #'(lambda ()
+ (unwind-protect
+ (progn
+ ;;(format t "~&Starting thread: ~S.~%" name) (finish-output)
+ (mt:thread-detach nil)
+ (funcall fn))
+ (progn
+ ;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output)
+ (mt:with-lock (*thread-id-map-lock*)
+ (remhash thread *id-thread-map*)
+ (remhash id *thread-id-map*))
+ ;;(format t "~&Finished thread: ~S~%" name) (finish-output)
+ ))))
+ (mt:thread-enable thread)
+ (mt:thread-yield)
+ thread
+ ))
+
+(defimplementation thread-id (thread)
+ (block thread-id
+ (mt:with-lock (*thread-id-map-lock*)
+ (or (gethash thread *id-thread-map*)
+ (let ((id (next-thread-id)))
+ (setf (gethash id *thread-id-map*) thread)
+ (setf (gethash thread *id-thread-map*) id)
+ id)))))
+
+(defimplementation find-thread (id)
+ (mt:with-lock (*thread-id-map-lock*)
+ (gethash id *thread-id-map*)))
+
+(defimplementation thread-name (thread)
+ (mt:thread-name thread))
+
+(defimplementation thread-status (thread)
+ (if (mt:thread-active-p thread)
+ "RUNNING"
+ "STOPPED"))
+
+(defimplementation make-lock (&key name)
+ (mt:make-lock :name name :recursive t))
+
+(defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (mt:with-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ mt:*thread*)
+
+(defimplementation all-threads ()
+ (mt:all-threads))
+
+(defimplementation interrupt-thread (thread fn)
+ (mt:interrupt-thread thread fn))
+
+(defimplementation kill-thread (thread)
+ (mt:interrupt-thread thread #'mt:terminate-thread)
+ )
+
+(defimplementation thread-alive-p (thread)
+ (mt:thread-active-p thread))
+
+(defvar *mailbox-lock* (mt:make-lock :name "mailbox lock"))
+(defvar *mailboxes* (list))
+(declaim (type list *mailboxes*))
+
+(defstruct (mailbox (:conc-name mailbox.))
+ thread
+ locked-by
+ (mutex (mt:make-lock :name "thread mailbox"))
+ (semaphore (mt:make-semaphore))
+ (queue '() :type list))
+
+(defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mt:with-lock (*mailbox-lock*)
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+(defimplementation send (thread message)
+ (handler-case
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+;; (mt:interrupt-thread
+;; thread
+;; (lambda ()
+;; (mt:with-lock (mutex)
+;; (setf (mailbox.queue mbox)
+;; (nconc (mailbox.queue mbox) (list message))))))
+
+;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%"
+;; mt:*thread* thread message) (finish-output)
+ (mt:with-lock (mutex)
+ (setf (mailbox.locked-by mbox) mt:*thread*)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ ;;(format t "*") (finish-output)
+ (handler-case
+ (mt:semaphore-signal (mailbox.semaphore mbox))
+ (condition (condition)
+ (format t "Something went bad with semaphore-signal ~A" condition) (finish-output)
+ ;;(break)
+ ))
+ (setf (mailbox.locked-by mbox) nil)
+ )
+ ;;(format t "+") (finish-output)
+ )
+ (condition (condition)
+ (format t "~&Error in send: ~S~%" condition) (finish-output))
+ )
+ )
+
+;; (defimplementation receive ()
+;; (block got-mail
+;; (let* ((mbox (mailbox mt:*thread*))
+;; (mutex (mailbox.mutex mbox)))
+;; (loop
+;; (mt:with-lock (mutex)
+;; (if (mailbox.queue mbox)
+;; (return-from got-mail (pop (mailbox.queue mbox)))))
+;; ;;interrupt-thread will halt this if it takes longer than 1sec
+;; (sleep 1)))))
+
+
+(defimplementation receive-if (test &optional timeout)
+ (handler-case
+ (let* ((mbox (mailbox (current-thread)))
+ (mutex (mailbox.mutex mbox))
+ got-one)
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ ;;(format t "~&: ~S~%" mt:*thread*) (finish-output)
+ (handler-case
+ (setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2))
+ (condition (condition)
+ (format t "~&In (swank-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition)
+ (finish-output)
+ nil
+ )
+ )
+ (mt:with-lock (mutex)
+ (setf (mailbox.locked-by mbox) mt:*thread*)
+ (let* ((q (mailbox.queue mbox))
+ (tail (member-if test q)))
+ (when tail
+ (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
+ (setf (mailbox.locked-by mbox) nil)
+ ;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail))
+ (return (car tail))))
+ (setf (mailbox.locked-by mbox) nil)
+ )
+
+ ;;(format t "/ ~S~%" mt:*thread*) (finish-output)
+ (when (eq timeout t) (return (values nil t)))
+;; (unless got-one
+;; (format t "~&In (swank-mkcl) receive-if: semaphore-wait timed out!~%"))
+ )
+ )
+ (condition (condition)
+ (format t "~&Error in (swank-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output)
+ nil
+ )
+ )
+ )
+
+
+(defmethod stream-finish-output ((stream stream))
+ (finish-output stream))
+
+
+;;
+
+;;#+windows
+(defimplementation doze-in-repl ()
+ (setq *inferior-lisp-sleeping-post* (mt:make-semaphore))
+ ;;(loop (sleep 1))
+ (mt:semaphore-wait *inferior-lisp-sleeping-post*)
+ (mk-ext:quit :verbose t)
+ )
+
diff --git a/vim/bundle/slimv/slime/swank/rpc.lisp b/vim/bundle/slimv/slime/swank/rpc.lisp
new file mode 100644
index 0000000..e30cc2c
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/rpc.lisp
@@ -0,0 +1,162 @@
+;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*-
+;;;
+;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems.
+;;;
+;;; Created 2010, Terje Norderhaug <terje@in-progress.com>
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(in-package swank/rpc)
+
+
+;;;;; Input
+
+(define-condition swank-reader-error (reader-error)
+ ((packet :type string :initarg :packet
+ :reader swank-reader-error.packet)
+ (cause :type reader-error :initarg :cause
+ :reader swank-reader-error.cause)))
+
+(defun read-message (stream package)
+ (let ((packet (read-packet stream)))
+ (handler-case (values (read-form packet package))
+ (reader-error (c)
+ (error 'swank-reader-error
+ :packet packet :cause c)))))
+
+(defun read-packet (stream)
+ (let* ((length (parse-header stream))
+ (octets (read-chunk stream length)))
+ (handler-case (swank/backend:utf8-to-string octets)
+ (error (c)
+ (error 'swank-reader-error
+ :packet (asciify octets)
+ :cause c)))))
+
+(defun asciify (packet)
+ (with-output-to-string (*standard-output*)
+ (loop for code across (etypecase packet
+ (string (map 'vector #'char-code packet))
+ (vector packet))
+ do (cond ((<= code #x7f) (write-char (code-char code)))
+ (t (format t "\\x~x" code))))))
+
+(defun parse-header (stream)
+ (parse-integer (map 'string #'code-char (read-chunk stream 6))
+ :radix 16))
+
+(defun read-chunk (stream length)
+ (let* ((buffer (make-array length :element-type '(unsigned-byte 8)))
+ (count (read-sequence buffer stream)))
+ (cond ((= count length)
+ buffer)
+ ((zerop count)
+ (error 'end-of-file :stream stream))
+ (t
+ (error "Short read: length=~D count=~D" length count)))))
+
+(defparameter *validate-input* nil
+ "Set to true to require input that more strictly conforms to the protocol")
+
+(defun read-form (string package)
+ (with-standard-io-syntax
+ (let ((*package* package))
+ (if *validate-input*
+ (validating-read string)
+ (read-from-string string)))))
+
+(defun validating-read (string)
+ (with-input-from-string (*standard-input* string)
+ (simple-read)))
+
+(defun simple-read ()
+ "Read a form that conforms to the protocol, otherwise signal an error."
+ (let ((c (read-char)))
+ (case c
+ (#\( (loop collect (simple-read)
+ while (ecase (read-char)
+ (#\) nil)
+ (#\space t))))
+ (#\' `(quote ,(simple-read)))
+ (t
+ (cond
+ ((digit-char-p c)
+ (parse-integer
+ (map 'simple-string #'identity
+ (loop for ch = c then (read-char nil nil)
+ while (and ch (digit-char-p ch))
+ collect ch
+ finally (unread-char ch)))))
+ ((or (member c '(#\: #\")) (alpha-char-p c))
+ (unread-char c)
+ (read-preserving-whitespace))
+ (t (error "Invalid character ~:c" c)))))))
+
+
+;;;;; Output
+
+(defun write-message (message package stream)
+ (let* ((string (prin1-to-string-for-emacs message package))
+ (octets (handler-case (swank/backend:string-to-utf8 string)
+ (error (c) (encoding-error c string))))
+ (length (length octets)))
+ (write-header stream length)
+ (write-sequence octets stream)
+ (finish-output stream)))
+
+;; FIXME: for now just tell emacs that we and an encoding problem.
+(defun encoding-error (condition string)
+ (swank/backend:string-to-utf8
+ (prin1-to-string-for-emacs
+ `(:reader-error
+ ,(asciify string)
+ ,(format nil "Error during string-to-utf8: ~a"
+ (or (ignore-errors (asciify (princ-to-string condition)))
+ (asciify (princ-to-string (type-of condition))))))
+ (find-package :cl))))
+
+(defun write-header (stream length)
+ (declare (type (unsigned-byte 24) length))
+ ;;(format *trace-output* "length: ~d (#x~x)~%" length length)
+ (loop for c across (format nil "~6,'0x" length)
+ do (write-byte (char-code c) stream)))
+
+(defun switch-to-double-floats (x)
+ (typecase x
+ (double-float x)
+ (float (coerce x 'double-float))
+ (null x)
+ (list (loop for (x . cdr) on x
+ collect (switch-to-double-floats x) into result
+ until (atom cdr)
+ finally (return (append result (switch-to-double-floats cdr)))))
+ (t x)))
+
+(defun prin1-to-string-for-emacs (object package)
+ (with-standard-io-syntax
+ (let ((*print-case* :downcase)
+ (*print-readably* nil)
+ (*print-pretty* nil)
+ (*package* package)
+ ;; Emacs has only double floats.
+ (*read-default-float-format* 'double-float))
+ (prin1-to-string (switch-to-double-floats object)))))
+
+
+#| TEST/DEMO:
+
+(defparameter *transport*
+ (with-output-to-string (out)
+ (write-message '(:message (hello "world")) *package* out)
+ (write-message '(:return 5) *package* out)
+ (write-message '(:emacs-rex NIL) *package* out)))
+
+*transport*
+
+(with-input-from-string (in *transport*)
+ (loop while (peek-char T in NIL)
+ collect (read-message in *package*)))
+
+|#
diff --git a/vim/bundle/slimv/slime/swank/sbcl.lisp b/vim/bundle/slimv/slime/swank/sbcl.lisp
new file mode 100644
index 0000000..b54fcd5
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/sbcl.lisp
@@ -0,0 +1,2044 @@
+;;;;; -*- 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))
+
+(defimplementation utf8-to-string (octets)
+ (sb-ext:octets-to-string octets :external-format :utf8))
+
+;;; 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 (name)
+ (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port &key backlog)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket (resolve-hostname host) 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 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))
+ (file (pathname stream)))
+ (unless (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 nil))
+
+(defvar *trap-load-time-warnings* t)
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (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)
+ append (loop for defsrc in 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))
+
+(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))))
+ (cond (*keep-non-valid-locals* all-vars)
+ (t (let ((loc (sb-di:frame-code-location frame)))
+ (remove-if (lambda (var)
+ (ecase (sb-di:debug-var-validity var loc)
+ (:valid nil)
+ ((:invalid :unknown) t)))
+ all-vars))))))
+
+(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))
+ (vars (frame-debug-vars frame))
+ ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
+ ;; specially.
+ (more-name (or (find-symbol "MORE" :sb-debug) 'more))
+ (more-context nil)
+ (more-count nil)
+ (more-id 0))
+ (when vars
+ (let ((locals
+ (loop for v across vars
+ do (when (eq (sb-di:debug-var-symbol v) more-name)
+ (incf more-id))
+ (case (debug-var-info v)
+ (:more-context
+ (setf more-context (debug-var-value v frame loc)))
+ (:more-count
+ (setf more-count (debug-var-value v frame loc))))
+ collect
+ (list :name (sb-di:debug-var-symbol v)
+ :id (sb-di:debug-var-id v)
+ :value (debug-var-value v frame loc)))))
+ (when (and more-context more-count)
+ (setf locals (append locals
+ (list
+ (list :name more-name
+ :id more-id
+ :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))
+ (vars (frame-debug-vars frame))
+ (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.
+ (let* ((context-var (find :more-context vars
+ :key #'debug-var-info))
+ (more-context (debug-var-value context-var frame
+ loc))
+ (count-var (find :more-count vars
+ :key #'debug-var-info))
+ (more-count (debug-var-value count-var frame loc)))
+ (return-from frame-var-value
+ (multiple-value-list (sb-c:%more-arg-values
+ more-context
+ 0 more-count))))
+ (aref vars var))))
+ (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))
+ (let ((header (sb-kernel:widetag-of o)))
+ (cond ((= header sb-vm:simple-fun-header-widetag)
+ (label-value-line*
+ (:name (sb-kernel:%simple-fun-name o))
+ (:arglist (sb-kernel:%simple-fun-arglist o))
+ (:self (sb-kernel:%simple-fun-self o))
+ (:next (sb-kernel:%simple-fun-next o))
+ (:type (sb-kernel:%simple-fun-type o))
+ (:code (sb-kernel:fun-code-header o))))
+ ((= header sb-vm:closure-header-widetag)
+ (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))
+ (:entry-points (sb-kernel:%code-entry-points 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)
+ (cond ((sb-kernel:%code-debug-info o)
+ (sb-disassem:disassemble-code-component o :stream s))
+ (t
+ (sb-disassem:disassemble-memory
+ (sb-disassem::align
+ (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
+ sb-vm:lowtag-mask)
+ (* sb-vm:code-constants-offset
+ sb-vm:n-word-bytes))
+ (ash 1 sb-vm:n-lowtag-bits))
+ (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
+ :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 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)))))
+
+
+ (defun condition-timed-wait (waitqueue mutex timeout)
+ (macrolet ((foo ()
+ (cond ((member :sb-lutex *features*) ; Darwin
+ '(sb-thread:condition-wait waitqueue mutex))
+ (t
+ '(handler-case
+ (let ((*break-on-signals* nil))
+ (sb-sys:with-deadline (:seconds timeout
+ :override t)
+ (sb-thread:condition-wait waitqueue mutex) t))
+ (sb-ext:timeout ()
+ nil))))))
+ (foo)))
+
+ (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)))
+ (condition-timed-wait waitq mutex 0.2)))))
+
+ (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)))))
+
+ ;; Workaround for deadlocks between the world-lock and auto-flush-thread
+ ;; buffer write lock.
+ ;;
+ ;; Another alternative would be to grab the world-lock here, but that's less
+ ;; future-proof, and could introduce other lock-ordering issues in the
+ ;; future.
+ ;;
+ ;; In an ideal world we would just have an :AROUND method on
+ ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this
+ ;; file is loaded -- so first we need a dummy definition that will be
+ ;; overridden by swank-gray.lisp.
+ #.(unless (find-package 'swank/gray) (make-package 'swank/gray) nil)
+ (eval-when (:load-toplevel :execute)
+ (unless (find-package 'swank/gray) (make-package 'swank/gray) nil))
+ (defclass swank/gray::slime-output-stream
+ (sb-gray:fundamental-character-output-stream)
+ ())
+ (defmethod sb-gray:stream-force-output
+ :around ((stream swank/gray::slime-output-stream))
+ (handler-case
+ (sb-sys:with-deadline (:seconds 0.1)
+ (call-next-method))
+ (sb-sys:deadline-timeout ()
+ nil)))
+ )
+
+(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))
+
+#-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)
+ (= i 1))
+
+ (defmethod sexp-ref ((s sb-impl::comma) i)
+ (sb-impl::comma-expr s)))
diff --git a/vim/bundle/slimv/slime/swank/scl.lisp b/vim/bundle/slimv/slime/swank/scl.lisp
new file mode 100644
index 0000000..7327133
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/scl.lisp
@@ -0,0 +1,1726 @@
+;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
+;;;
+;;; Scieneer Common Lisp code for SLIME.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(defpackage swank/scl
+ (:use cl swank/backend swank/source-path-parser swank/source-file-cache))
+
+(in-package swank/scl)
+
+
+
+;;; swank-mop
+
+(import-swank-mop-symbols :clos '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (documentation slot t))
+
+
+;;;; TCP server
+;;;
+;;; SCL only supports the :spawn communication style.
+;;;
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defimplementation create-socket (host port &key backlog)
+ (let ((addr (resolve-hostname host)))
+ (ext:create-inet-listener port :stream :host addr :reuse-address t
+ :backlog (or backlog 5))))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
+
+(defimplementation close-socket (socket)
+ (ext:close-socket (socket-fd socket)))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (let ((buffering (or buffering :full))
+ (fd (socket-fd socket)))
+ (loop
+ (let ((ready (sys:wait-until-fd-usable fd :input timeout)))
+ (unless ready
+ (error "Timeout accepting connection on socket: ~S~%" socket)))
+ (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
+ (when new-fd
+ (return (make-socket-io-stream new-fd external-format
+ (ecase buffering
+ ((t) :full)
+ ((nil) :none)
+ (:line :line)))))))))
+
+(defimplementation set-stream-timeout (stream timeout)
+ (check-type timeout (or null real))
+ (if (fboundp 'ext::stream-timeout)
+ (setf (ext::stream-timeout stream) timeout)
+ (setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout)
+ timeout)))
+
+;;;;; Sockets
+
+(defun socket-fd (socket)
+ "Return the file descriptor for the socket represented by 'socket."
+ (etypecase socket
+ (fixnum socket)
+ (stream (sys:fd-stream-fd socket))))
+
+(defun resolve-hostname (hostname)
+ "Return the IP address of 'hostname as an integer (in host byte-order)."
+ (let ((hostent (ext:lookup-host-entry hostname)))
+ (car (ext:host-entry-addr-list hostent))))
+
+(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")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defun make-socket-io-stream (fd external-format buffering)
+ "Create a new input/output fd-stream for 'fd."
+ (cond ((not external-format)
+ (sys:make-fd-stream fd :input t :output t :buffering buffering
+ :element-type '(unsigned-byte 8)))
+ (t
+ (let* ((stream (sys:make-fd-stream fd :input t :output t
+ :element-type 'base-char
+ :buffering buffering
+ :external-format external-format)))
+ ;; Ignore character conversion errors. Without this the
+ ;; communication channel is prone to lockup if a character
+ ;; conversion error occurs.
+ (setf (lisp::character-conversion-stream-input-error-value stream)
+ #\?)
+ (setf (lisp::character-conversion-stream-output-error-value stream)
+ #\?)
+ stream))))
+
+
+;;;; Stream handling
+
+(defimplementation gray-package-name ()
+ '#:ext)
+
+
+;;;; Compilation Commands
+
+(defvar *previous-compiler-condition* nil
+ "Used to detect duplicates.")
+
+(defvar *previous-context* nil
+ "Previous compiler error context.")
+
+(defvar *buffer-name* nil
+ "The name of the Emacs buffer we are compiling from.
+ Nil if we aren't compiling from a buffer.")
+
+(defvar *buffer-start-position* nil)
+(defvar *buffer-substring* nil)
+
+(defimplementation call-with-compilation-hooks (function)
+ (let ((*previous-compiler-condition* nil)
+ (*previous-context* nil)
+ (*print-readably* nil))
+ (handler-bind ((c::compiler-error #'handle-notification-condition)
+ (c::style-warning #'handle-notification-condition)
+ (c::warning #'handle-notification-condition))
+ (funcall function))))
+
+(defimplementation swank-compile-file (input-file output-file
+ load-p external-format
+ &key policy)
+ (declare (ignore policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (ext:*ignore-extra-close-parentheses* nil))
+ (multiple-value-bind (output-file warnings-p failure-p)
+ (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)))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+ policy)
+ (declare (ignore filename policy))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-substring* string))
+ (with-input-from-string (stream string)
+ (ext:compile-from-stream
+ stream
+ :source-info `(:emacs-buffer ,buffer
+ :emacs-buffer-offset ,position
+ :emacs-buffer-string ,string))))))
+
+
+;;;;; Trapping notes
+;;;
+;;; We intercept conditions from the compiler and resignal them as
+;;; `swank:compiler-condition's.
+
+(defun handle-notification-condition (condition)
+ "Handle a condition caused by a compiler warning."
+ (unless (eq condition *previous-compiler-condition*)
+ (let ((context (c::find-error-context nil)))
+ (setq *previous-compiler-condition* condition)
+ (setq *previous-context* context)
+ (signal-compiler-condition condition context))))
+
+(defun signal-compiler-condition (condition context)
+ (signal 'compiler-condition
+ :original-condition condition
+ :severity (severity-for-emacs condition)
+ :message (brief-compiler-message-for-emacs condition)
+ :source-context (compiler-error-context context)
+ :location (if (read-error-p condition)
+ (read-error-location condition)
+ (compiler-note-location context))))
+
+(defun severity-for-emacs (condition)
+ "Return the severity of 'condition."
+ (etypecase condition
+ ((satisfies read-error-p) :read-error)
+ (c::compiler-error :error)
+ (c::style-warning :note)
+ (c::warning :warning)))
+
+(defun read-error-p (condition)
+ (eq (type-of condition) 'c::compiler-read-error))
+
+(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."
+ (princ-to-string condition))
+
+(defun compiler-error-context (error-context)
+ "Describe a compiler error for Emacs including context information."
+ (declare (type (or c::compiler-error-context null) error-context))
+ (multiple-value-bind (enclosing source)
+ (if error-context
+ (values (c::compiler-error-context-enclosing-source error-context)
+ (c::compiler-error-context-source error-context)))
+ (if (and enclosing source)
+ (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]"
+ enclosing source))))
+
+(defun read-error-location (condition)
+ (let* ((finfo (car (c::source-info-current-file c::*source-info*)))
+ (file (c::file-info-name finfo))
+ (pos (c::compiler-read-error-position condition)))
+ (cond ((and (eq file :stream) *buffer-name*)
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position* pos)))
+ ((and (pathnamep file) (not *buffer-name*))
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ pos))))
+ (t (break)))))
+
+(defun compiler-note-location (context)
+ "Derive the location of a complier message from its context.
+ Return a `location' record, or (:error <reason>) on failure."
+ (if (null context)
+ (note-error-location)
+ (let ((file (c::compiler-error-context-file-name context))
+ (source (c::compiler-error-context-original-source context))
+ (path
+ (reverse
+ (c::compiler-error-context-original-source-path context))))
+ (or (locate-compiler-note file source path)
+ (note-error-location)))))
+
+(defun note-error-location ()
+ "Pseudo-location for notes that can't be located."
+ (list :error "No error location available."))
+
+(defun locate-compiler-note (file source source-path)
+ (cond ((and (eq file :stream) *buffer-name*)
+ ;; Compiling from a buffer
+ (make-location (list :buffer *buffer-name*)
+ (list :offset *buffer-start-position*
+ (source-path-string-position
+ source-path *buffer-substring*))))
+ ((and (pathnamep file) (null *buffer-name*))
+ ;; Compiling from a file
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ (source-path-file-position
+ source-path file)))))
+ ((and (eq file :lisp) (stringp source))
+ ;; No location known, but we have the source form.
+ ;; XXX How is this case triggered? -luke (16/May/2004)
+ ;; This can happen if the compiler needs to expand a macro
+ ;; but the macro-expander is not yet compiled. Calling the
+ ;; (interpreted) macro-expander triggers IR1 conversion of
+ ;; the lambda expression for the expander and invokes the
+ ;; compiler recursively.
+ (make-location (list :source-form source)
+ (list :position 1)))))
+
+(defun unix-truename (pathname)
+ (ext:unix-namestring (truename pathname)))
+
+
+
+;;; TODO
+(defimplementation who-calls (name) nil)
+(defimplementation who-references (name) nil)
+(defimplementation who-binds (name) nil)
+(defimplementation who-sets (name) nil)
+(defimplementation who-specializes (symbol) nil)
+(defimplementation who-macroexpands (name) nil)
+
+
+;;;; Find callers and callees
+;;;
+;;; Find callers and callees by looking at the constant pool of
+;;; compiled code objects. We assume every fdefn object in the
+;;; constant pool corresponds to a call to that function. A better
+;;; strategy would be to use the disassembler to find actual
+;;; call-sites.
+
+(declaim (inline map-code-constants))
+(defun map-code-constants (code fn)
+ "Call 'fn for each constant in 'code's constant pool."
+ (check-type code kernel:code-component)
+ (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
+ do (funcall fn (kernel:code-header-ref code i))))
+
+(defun function-callees (function)
+ "Return 'function's callees as a list of functions."
+ (let ((callees '()))
+ (map-code-constants
+ (vm::find-code-object function)
+ (lambda (obj)
+ (when (kernel:fdefn-p obj)
+ (push (kernel:fdefn-function obj) callees))))
+ callees))
+
+(declaim (ext:maybe-inline map-allocated-code-components))
+(defun map-allocated-code-components (spaces fn)
+ "Call FN for each allocated code component in one of 'spaces. FN
+ receives the object as argument. 'spaces should be a list of the
+ symbols :dynamic, :static, or :read-only."
+ (dolist (space spaces)
+ (declare (inline vm::map-allocated-objects)
+ (optimize (ext:inhibit-warnings 3)))
+ (vm::map-allocated-objects
+ (lambda (obj header size)
+ (declare (type fixnum size) (ignore size))
+ (when (= vm:code-header-type header)
+ (funcall fn obj)))
+ space)))
+
+(declaim (ext:maybe-inline map-caller-code-components))
+(defun map-caller-code-components (function spaces fn)
+ "Call 'fn for each code component with a fdefn for 'function in its
+ constant pool."
+ (let ((function (coerce function 'function)))
+ (declare (inline map-allocated-code-components))
+ (map-allocated-code-components
+ spaces
+ (lambda (obj)
+ (map-code-constants
+ obj
+ (lambda (constant)
+ (when (and (kernel:fdefn-p constant)
+ (eq (kernel:fdefn-function constant)
+ function))
+ (funcall fn obj))))))))
+
+(defun function-callers (function &optional (spaces '(:read-only :static
+ :dynamic)))
+ "Return 'function's callers. The result is a list of code-objects."
+ (let ((referrers '()))
+ (declare (inline map-caller-code-components))
+ (map-caller-code-components function spaces
+ (lambda (code) (push code referrers)))
+ referrers))
+
+(defun debug-info-definitions (debug-info)
+ "Return the defintions for a debug-info. This should only be used
+ for code-object without entry points, i.e., byte compiled
+ code (are theree others?)"
+ ;; This mess has only been tested with #'ext::skip-whitespace, a
+ ;; byte-compiled caller of #'read-char .
+ (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
+ (let ((name (c::debug-info-name debug-info))
+ (source (c::debug-info-source debug-info)))
+ (destructuring-bind (first) source
+ (ecase (c::debug-source-from first)
+ (:file
+ (list (list name
+ (make-location
+ (list :file (unix-truename (c::debug-source-name first)))
+ (list :function-name (string name))))))))))
+
+(defun valid-function-name-p (name)
+ (or (symbolp name) (and (consp name)
+ (eq (car name) 'setf)
+ (symbolp (cadr name))
+ (not (cddr name)))))
+
+(defun code-component-entry-points (code)
+ "Return a list ((name location) ...) of function definitons for
+ the code omponent 'code."
+ (let ((names '()))
+ (do ((f (kernel:%code-entry-points code) (kernel::%function-next f)))
+ ((not f))
+ (let ((name (kernel:%function-name f)))
+ (when (valid-function-name-p name)
+ (push (list name (function-location f)) names))))
+ names))
+
+(defimplementation list-callers (symbol)
+ "Return a list ((name location) ...) of callers."
+ (let ((components (function-callers symbol))
+ (xrefs '()))
+ (dolist (code components)
+ (let* ((entry (kernel:%code-entry-points code))
+ (defs (if entry
+ (code-component-entry-points code)
+ ;; byte compiled stuff
+ (debug-info-definitions
+ (kernel:%code-debug-info code)))))
+ (setq xrefs (nconc defs xrefs))))
+ xrefs))
+
+(defimplementation list-callees (symbol)
+ (let ((fns (function-callees symbol)))
+ (mapcar (lambda (fn)
+ (list (kernel:%function-name fn)
+ (function-location fn)))
+ fns)))
+
+
+;;;; Resolving source locations
+;;;
+;;; Our mission here is to "resolve" references to code locations into
+;;; actual file/buffer names and character positions. The references
+;;; we work from come out of the compiler's statically-generated debug
+;;; information, such as `code-location''s and `debug-source''s. For
+;;; more details, see the "Debugger Programmer's Interface" section of
+;;; the SCL manual.
+;;;
+;;; The first step is usually to find the corresponding "source-path"
+;;; for the location. Once we have the source-path we can pull up the
+;;; source file and `READ' our way through to the right position. The
+;;; main source-code groveling work is done in
+;;; `source-path-parser.lisp'.
+
+(defvar *debug-definition-finding* nil
+ "When true don't handle errors while looking for definitions.
+ This is useful when debugging the definition-finding code.")
+
+(defmacro safe-definition-finding (&body body)
+ "Execute 'body and return the source-location it returns.
+ If an error occurs and `*debug-definition-finding*' is false, then
+ return an error pseudo-location.
+
+ The second return value is 'nil if no error occurs, otherwise it is the
+ condition object."
+ `(flet ((body () ,@body))
+ (if *debug-definition-finding*
+ (body)
+ (handler-case (values (progn ,@body) nil)
+ (error (c) (values (list :error (princ-to-string c)) c))))))
+
+(defun code-location-source-location (code-location)
+ "Safe wrapper around `code-location-from-source-location'."
+ (safe-definition-finding
+ (source-location-from-code-location code-location)))
+
+(defun source-location-from-code-location (code-location)
+ "Return the source location for 'code-location."
+ (let ((debug-fun (di:code-location-debug-function code-location)))
+ (when (di::bogus-debug-function-p debug-fun)
+ ;; Those lousy cheapskates! They've put in a bogus debug source
+ ;; because the code was compiled at a low debug setting.
+ (error "Bogus debug function: ~A" debug-fun)))
+ (let* ((debug-source (di:code-location-debug-source code-location))
+ (from (di:debug-source-from debug-source))
+ (name (di:debug-source-name debug-source)))
+ (ecase from
+ (:file
+ (location-in-file name code-location debug-source))
+ (:stream
+ (location-in-stream code-location debug-source))
+ (:lisp
+ ;; The location comes from a form passed to `compile'.
+ ;; The best we can do is return the form itself for printing.
+ (make-location
+ (list :source-form (with-output-to-string (*standard-output*)
+ (debug::print-code-location-source-form
+ code-location 100 t)))
+ (list :position 1))))))
+
+(defun location-in-file (filename code-location debug-source)
+ "Resolve the source location for 'code-location in 'filename."
+ (let* ((code-date (di:debug-source-created debug-source))
+ (source-code (get-source-code filename code-date)))
+ (with-input-from-string (s source-code)
+ (make-location (list :file (unix-truename filename))
+ (list :position (1+ (code-location-stream-position
+ code-location s)))
+ `(:snippet ,(read-snippet s))))))
+
+(defun location-in-stream (code-location debug-source)
+ "Resolve the source location for a 'code-location from a stream.
+ This only succeeds if the code was compiled from an Emacs buffer."
+ (unless (debug-source-info-from-emacs-buffer-p debug-source)
+ (error "The code is compiled from a non-SLIME stream."))
+ (let* ((info (c::debug-source-info debug-source))
+ (string (getf info :emacs-buffer-string))
+ (position (code-location-string-offset
+ code-location
+ string)))
+ (make-location
+ (list :buffer (getf info :emacs-buffer))
+ (list :offset (getf info :emacs-buffer-offset) position)
+ (list :snippet (with-input-from-string (s string)
+ (file-position s position)
+ (read-snippet s))))))
+
+;;;;; Function-name locations
+;;;
+(defun debug-info-function-name-location (debug-info)
+ "Return a function-name source-location for 'debug-info.
+ Function-name source-locations are a fallback for when precise
+ positions aren't available."
+ (with-struct (c::debug-info- (fname name) source) debug-info
+ (with-struct (c::debug-source- info from name) (car source)
+ (ecase from
+ (:file
+ (make-location (list :file (namestring (truename name)))
+ (list :function-name (string fname))))
+ (:stream
+ (assert (debug-source-info-from-emacs-buffer-p (car source)))
+ (make-location (list :buffer (getf info :emacs-buffer))
+ (list :function-name (string fname))))
+ (:lisp
+ (make-location (list :source-form (princ-to-string (aref name 0)))
+ (list :position 1)))))))
+
+(defun debug-source-info-from-emacs-buffer-p (debug-source)
+ "Does the `info' slot of 'debug-source contain an Emacs buffer location?
+ This is true for functions that were compiled directly from buffers."
+ (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
+
+(defun info-from-emacs-buffer-p (info)
+ (and info
+ (consp info)
+ (eq :emacs-buffer (car info))))
+
+
+;;;;; Groveling source-code for positions
+
+(defun code-location-stream-position (code-location stream)
+ "Return the byte offset of 'code-location in 'stream. Extract the
+ toplevel-form-number and form-number from 'code-location and use that
+ to find the position of the corresponding form.
+
+ Finish with 'stream positioned at the start of the code location."
+ (let* ((location (debug::maybe-block-start-location code-location))
+ (tlf-offset (di:code-location-top-level-form-offset location))
+ (form-number (di:code-location-form-number location)))
+ (let ((pos (form-number-stream-position tlf-offset form-number stream)))
+ (file-position stream pos)
+ pos)))
+
+(defun form-number-stream-position (tlf-number form-number stream)
+ "Return the starting character position of a form in 'stream.
+ 'tlf-number is the top-level-form number.
+ 'form-number is an index into a source-path table for the TLF."
+ (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
+ (let* ((path-table (di:form-number-translations tlf 0))
+ (source-path
+ (if (<= (length path-table) form-number) ; source out of sync?
+ (list 0) ; should probably signal a condition
+ (reverse (cdr (aref path-table form-number))))))
+ (source-path-source-position source-path tlf position-map))))
+
+(defun code-location-string-offset (code-location string)
+ "Return the byte offset of 'code-location in 'string.
+ See 'code-location-stream-position."
+ (with-input-from-string (s string)
+ (code-location-stream-position code-location s)))
+
+
+;;;; Finding definitions
+
+;;; There are a great many different types of definition for us to
+;;; find. We search for definitions of every kind and return them in a
+;;; list.
+
+(defimplementation find-definitions (name)
+ (append (function-definitions name)
+ (setf-definitions name)
+ (variable-definitions name)
+ (class-definitions name)
+ (type-definitions name)
+ (compiler-macro-definitions name)
+ (source-transform-definitions name)
+ (function-info-definitions name)
+ (ir1-translator-definitions name)))
+
+;;;;; Functions, macros, generic functions, methods
+;;;
+;;; We make extensive use of the compile-time debug information that
+;;; SCL records, in particular "debug functions" and "code
+;;; locations." Refer to the "Debugger Programmer's Interface" section
+;;; of the SCL manual for more details.
+
+(defun function-definitions (name)
+ "Return definitions for 'name in the \"function namespace\", i.e.,
+ regular functions, generic functions, methods and macros.
+ 'name can any valid function name (e.g, (setf car))."
+ (let ((macro? (and (symbolp name) (macro-function name)))
+ (special? (and (symbolp name) (special-operator-p name)))
+ (function? (and (valid-function-name-p name)
+ (ext:info :function :definition name)
+ (if (symbolp name) (fboundp name) t))))
+ (cond (macro?
+ (list `((defmacro ,name)
+ ,(function-location (macro-function name)))))
+ (special?
+ (list `((:special-operator ,name)
+ (:error ,(format nil "Special operator: ~S" name)))))
+ (function?
+ (let ((function (fdefinition name)))
+ (if (genericp function)
+ (generic-function-definitions name function)
+ (list (list `(function ,name)
+ (function-location function)))))))))
+
+;;;;;; Ordinary (non-generic/macro/special) functions
+;;;
+;;; First we test if FUNCTION is a closure created by defstruct, and
+;;; if so extract the defstruct-description (`dd') from the closure
+;;; and find the constructor for the struct. Defstruct creates a
+;;; defun for the default constructor and we use that as an
+;;; approximation to the source location of the defstruct.
+;;;
+;;; For an ordinary function we return the source location of the
+;;; first code-location we find.
+;;;
+(defun function-location (function)
+ "Return the source location for FUNCTION."
+ (cond ((struct-closure-p function)
+ (struct-closure-location function))
+ ((c::byte-function-or-closure-p function)
+ (byte-function-location function))
+ (t
+ (compiled-function-location function))))
+
+(defun compiled-function-location (function)
+ "Return the location of a regular compiled function."
+ (multiple-value-bind (code-location error)
+ (safe-definition-finding (function-first-code-location function))
+ (cond (error (list :error (princ-to-string error)))
+ (t (code-location-source-location code-location)))))
+
+(defun function-first-code-location (function)
+ "Return the first code-location we can find for 'function."
+ (and (function-has-debug-function-p function)
+ (di:debug-function-start-location
+ (di:function-debug-function function))))
+
+(defun function-has-debug-function-p (function)
+ (di:function-debug-function function))
+
+(defun function-code-object= (closure function)
+ (and (eq (vm::find-code-object closure)
+ (vm::find-code-object function))
+ (not (eq closure function))))
+
+
+(defun byte-function-location (fn)
+ "Return the location of the byte-compiled function 'fn."
+ (etypecase fn
+ ((or c::hairy-byte-function c::simple-byte-function)
+ (let* ((component (c::byte-function-component fn))
+ (debug-info (kernel:%code-debug-info component)))
+ (debug-info-function-name-location debug-info)))
+ (c::byte-closure
+ (byte-function-location (c::byte-closure-function fn)))))
+
+;;; Here we deal with structure accessors. Note that `dd' is a
+;;; "defstruct descriptor" structure in SCL. A `dd' describes a
+;;; `defstruct''d structure.
+
+(defun struct-closure-p (function)
+ "Is 'function a closure created by defstruct?"
+ (or (function-code-object= function #'kernel::structure-slot-accessor)
+ (function-code-object= function #'kernel::structure-slot-setter)
+ (function-code-object= function #'kernel::%defstruct)))
+
+(defun struct-closure-location (function)
+ "Return the location of the structure that 'function belongs to."
+ (assert (struct-closure-p function))
+ (safe-definition-finding
+ (dd-location (struct-closure-dd function))))
+
+(defun struct-closure-dd (function)
+ "Return the defstruct-definition (dd) of FUNCTION."
+ (assert (= (kernel:get-type function) vm:closure-header-type))
+ (flet ((find-layout (function)
+ (sys:find-if-in-closure
+ (lambda (x)
+ (let ((value (if (di::indirect-value-cell-p x)
+ (c:value-cell-ref x)
+ x)))
+ (when (kernel::layout-p value)
+ (return-from find-layout value))))
+ function)))
+ (kernel:layout-info (find-layout function))))
+
+(defun dd-location (dd)
+ "Return the location of a `defstruct'."
+ ;; Find the location in a constructor.
+ (function-location (struct-constructor dd)))
+
+(defun struct-constructor (dd)
+ "Return a constructor function from a defstruct definition.
+Signal an error if no constructor can be found."
+ (let ((constructor (or (kernel:dd-default-constructor dd)
+ (car (kernel::dd-constructors dd)))))
+ (when (or (null constructor)
+ (and (consp constructor) (null (car constructor))))
+ (error "Cannot find structure's constructor: ~S"
+ (kernel::dd-name dd)))
+ (coerce (if (consp constructor) (first constructor) constructor)
+ 'function)))
+
+;;;;;; Generic functions and methods
+
+(defun generic-function-definitions (name function)
+ "Return the definitions of a generic function and its methods."
+ (cons (list `(defgeneric ,name) (gf-location function))
+ (gf-method-definitions function)))
+
+(defun gf-location (gf)
+ "Return the location of the generic function GF."
+ (definition-source-location gf (clos:generic-function-name gf)))
+
+(defun gf-method-definitions (gf)
+ "Return the locations of all methods of the generic function GF."
+ (mapcar #'method-definition (clos:generic-function-methods gf)))
+
+(defun method-definition (method)
+ (list (method-dspec method)
+ (method-location method)))
+
+(defun method-dspec (method)
+ "Return a human-readable \"definition specifier\" for METHOD."
+ (let* ((gf (clos:method-generic-function method))
+ (name (clos:generic-function-name gf))
+ (specializers (clos:method-specializers method))
+ (qualifiers (clos:method-qualifiers method)))
+ `(method ,name ,@qualifiers ,specializers
+ #+nil (clos::unparse-specializers specializers))))
+
+;; XXX maybe special case setters/getters
+(defun method-location (method)
+ (function-location (clos:method-function method)))
+
+(defun genericp (fn)
+ (typep fn 'generic-function))
+
+;;;;;; Types and classes
+
+(defun type-definitions (name)
+ "Return `deftype' locations for type NAME."
+ (maybe-make-definition (ext:info :type :expander name) 'deftype name))
+
+(defun maybe-make-definition (function kind name)
+ "If FUNCTION is non-nil then return its definition location."
+ (if function
+ (list (list `(,kind ,name) (function-location function)))))
+
+(defun class-definitions (name)
+ "Return the definition locations for the class called NAME."
+ (if (symbolp name)
+ (let ((class (find-class name nil)))
+ (etypecase class
+ (null '())
+ (structure-class
+ (list (list `(defstruct ,name)
+ (dd-location (find-dd name)))))
+ (standard-class
+ (list (list `(defclass ,name)
+ (class-location (find-class name)))))
+ ((or built-in-class
+ kernel:funcallable-structure-class)
+ (list (list `(kernel::define-type-class ,name)
+ `(:error
+ ,(format nil "No source info for ~A" name)))))))))
+
+(defun class-location (class)
+ "Return the `defclass' location for CLASS."
+ (definition-source-location class (class-name class)))
+
+(defun find-dd (name)
+ "Find the defstruct-definition by the name of its structure-class."
+ (let ((layout (ext:info :type :compiler-layout name)))
+ (if layout
+ (kernel:layout-info layout))))
+
+(defun condition-class-location (class)
+ (let ((name (class-name class)))
+ `(:error ,(format nil "No location info for condition: ~A" name))))
+
+(defun make-name-in-file-location (file string)
+ (multiple-value-bind (filename c)
+ (ignore-errors
+ (unix-truename (merge-pathnames (make-pathname :type "lisp")
+ file)))
+ (cond (filename (make-location `(:file ,filename)
+ `(:function-name ,(string string))))
+ (t (list :error (princ-to-string c))))))
+
+(defun definition-source-location (object name)
+ `(:error ,(format nil "No source info for: ~A" object)))
+
+(defun setf-definitions (name)
+ (let ((function (or (ext:info :setf :inverse name)
+ (ext:info :setf :expander name))))
+ (if function
+ (list (list `(setf ,name)
+ (function-location (coerce function 'function)))))))
+
+
+(defun variable-location (symbol)
+ `(:error ,(format nil "No source info for variable ~S" symbol)))
+
+(defun variable-definitions (name)
+ (if (symbolp name)
+ (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
+ (if recorded-p
+ (list (list `(variable ,kind ,name)
+ (variable-location name)))))))
+
+(defun compiler-macro-definitions (symbol)
+ (maybe-make-definition (compiler-macro-function symbol)
+ 'define-compiler-macro
+ symbol))
+
+(defun source-transform-definitions (name)
+ (maybe-make-definition (ext:info :function :source-transform name)
+ 'c:def-source-transform
+ name))
+
+(defun function-info-definitions (name)
+ (let ((info (ext:info :function :info name)))
+ (if info
+ (append (loop for transform in (c::function-info-transforms info)
+ collect (list `(c:deftransform ,name
+ ,(c::type-specifier
+ (c::transform-type transform)))
+ (function-location (c::transform-function
+ transform))))
+ (maybe-make-definition (c::function-info-derive-type info)
+ 'c::derive-type name)
+ (maybe-make-definition (c::function-info-optimizer info)
+ 'c::optimizer name)
+ (maybe-make-definition (c::function-info-ltn-annotate info)
+ 'c::ltn-annotate name)
+ (maybe-make-definition (c::function-info-ir2-convert info)
+ 'c::ir2-convert name)
+ (loop for template in (c::function-info-templates info)
+ collect (list `(c::vop ,(c::template-name template))
+ (function-location
+ (c::vop-info-generator-function
+ template))))))))
+
+(defun ir1-translator-definitions (name)
+ (maybe-make-definition (ext:info :function :ir1-convert name)
+ 'c:def-ir1-translator name))
+
+
+;;;; Documentation.
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (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)
+ (ext: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)
+ ((genericp (fdefinition symbol)) :generic-function)
+ (t :function))
+ (doc 'function)))
+ (maybe-push
+ :setf (if (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol))
+ (doc 'setf)))
+ (maybe-push
+ :type (if (ext:info type kind symbol)
+ (doc 'type)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ (maybe-push
+ :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
+ (doc 'alien-type)))
+ (maybe-push
+ :alien-struct (if (ext:info alien-type struct symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-union (if (ext:info alien-type union symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-enum (if (ext:info alien-type enum symbol)
+ (doc nil)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (describe (ecase namespace
+ (:variable
+ symbol)
+ ((:function :generic-function)
+ (symbol-function symbol))
+ (:setf
+ (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol)))
+ (:type
+ (kernel:values-specifier-type symbol))
+ (:class
+ (find-class symbol))
+ (:alien-struct
+ (ext:info :alien-type :struct symbol))
+ (:alien-union
+ (ext:info :alien-type :union symbol))
+ (:alien-enum
+ (ext:info :alien-type :enum symbol))
+ (:alien-type
+ (ecase (ext:info :alien-type :kind symbol)
+ (:primitive
+ (let ((alien::*values-type-okay* t))
+ (funcall (ext:info :alien-type :translator symbol)
+ (list symbol))))
+ ((:defined)
+ (ext:info :alien-type :definition symbol))
+ (:unknown :unknown))))))
+
+;;;;; Argument lists
+
+(defimplementation arglist (fun)
+ (multiple-value-bind (args winp)
+ (ext:function-arglist fun)
+ (if winp args :not-available)))
+
+(defimplementation function-name (function)
+ (cond ((eval:interpreted-function-p function)
+ (eval:interpreted-function-name function))
+ ((typep function 'generic-function)
+ (clos:generic-function-name function))
+ ((c::byte-function-or-closure-p function)
+ (c::byte-function-name function))
+ (t (kernel:%function-name (kernel:%function-self function)))))
+
+
+;;; A harder case: an approximate arglist is derived from available
+;;; debugging information.
+
+(defun debug-function-arglist (debug-function)
+ "Derive the argument list of DEBUG-FUNCTION from debug info."
+ (let ((args (di::debug-function-lambda-list debug-function))
+ (required '())
+ (optional '())
+ (rest '())
+ (key '()))
+ ;; collect the names of debug-vars
+ (dolist (arg args)
+ (etypecase arg
+ (di::debug-variable
+ (push (di::debug-variable-symbol arg) required))
+ ((member :deleted)
+ (push ':deleted required))
+ (cons
+ (ecase (car arg)
+ (:keyword
+ (push (second arg) key))
+ (:optional
+ (push (debug-variable-symbol-or-deleted (second arg)) optional))
+ (:rest
+ (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
+ ;; intersperse lambda keywords as needed
+ (append (nreverse required)
+ (if optional (cons '&optional (nreverse optional)))
+ (if rest (cons '&rest (nreverse rest)))
+ (if key (cons '&key (nreverse key))))))
+
+(defun debug-variable-symbol-or-deleted (var)
+ (etypecase var
+ (di:debug-variable
+ (di::debug-variable-symbol var))
+ ((member :deleted)
+ '#:deleted)))
+
+(defun symbol-debug-function-arglist (fname)
+ "Return FNAME's debug-function-arglist and %function-arglist.
+ A utility for debugging DEBUG-FUNCTION-ARGLIST."
+ (let ((fn (fdefinition fname)))
+ (values (debug-function-arglist (di::function-debug-function fn))
+ (kernel:%function-arglist (kernel:%function-self fn)))))
+
+
+;;;; Miscellaneous.
+
+(defimplementation macroexpand-all (form &optional env)
+ (declare (ignore env))
+ (macroexpand form))
+
+(defimplementation set-default-directory (directory)
+ (setf (ext:default-directory) (namestring directory))
+ ;; Setting *default-pathname-defaults* to an absolute directory
+ ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
+ (setf *default-pathname-defaults* (pathname (ext:default-directory)))
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (ext:default-directory)))
+
+(defimplementation pathname-to-filename (pathname)
+ (ext:unix-namestring pathname nil))
+
+(defimplementation getpid ()
+ (unix:unix-getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ (if (eq ext:*case-mode* :upper) "scl" "scl-lower"))
+
+(defimplementation quit-lisp ()
+ (ext:quit))
+
+;;; source-path-{stream,file,string,etc}-position moved into
+;;; source-path-parser
+
+
+;;;; Debugging
+
+(defvar *sldb-stack-top*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
+ (debug:*stack-top-hint* nil)
+ (kernel:*current-level* 0))
+ (handler-bind ((di::unhandled-condition
+ (lambda (condition)
+ (error 'sldb-condition
+ :original-condition condition))))
+ (funcall debugger-loop-fn))))
+
+(defun frame-down (frame)
+ (handler-case (di:frame-down frame)
+ (di:no-debug-info () nil)))
+
+(defun nth-frame (index)
+ (do ((frame *sldb-stack-top* (frame-down frame))
+ (i index (1- i)))
+ ((zerop i) frame)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (loop for f = (nth-frame start) then (frame-down f)
+ for i from start below end
+ while f collect f)))
+
+(defimplementation print-frame (frame stream)
+ (let ((*standard-output* stream))
+ (handler-case
+ (debug::print-frame-call frame :verbosity 1 :number nil)
+ (error (e)
+ (ignore-errors (princ e stream))))))
+
+(defimplementation frame-source-location (index)
+ (code-location-source-location (di:frame-code-location (nth-frame index))))
+
+(defimplementation eval-in-frame (form index)
+ (di:eval-in-frame (nth-frame index) form))
+
+(defun frame-debug-vars (frame)
+ "Return a vector of debug-variables in frame."
+ (di::debug-function-debug-variables (di:frame-debug-function frame)))
+
+(defun debug-var-value (var frame location)
+ (let ((validity (di:debug-variable-validity var location)))
+ (ecase validity
+ (:valid (di:debug-variable-value var frame))
+ ((:invalid :unknown) (make-symbol (string validity))))))
+
+(defimplementation frame-locals (index)
+ (let* ((frame (nth-frame index))
+ (loc (di:frame-code-location frame))
+ (vars (frame-debug-vars frame)))
+ (loop for v across vars collect
+ (list :name (di:debug-variable-symbol v)
+ :id (di:debug-variable-id v)
+ :value (debug-var-value v frame loc)))))
+
+(defimplementation frame-var-value (frame var)
+ (let* ((frame (nth-frame frame))
+ (dvar (aref (frame-debug-vars frame) var)))
+ (debug-var-value dvar frame (di:frame-code-location frame))))
+
+(defimplementation frame-catch-tags (index)
+ (mapcar #'car (di:frame-catches (nth-frame index))))
+
+(defimplementation return-from-frame (index form)
+ (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame)
+ :debug-internals)))
+ (if sym
+ (let* ((frame (nth-frame index))
+ (probe (funcall sym frame)))
+ (cond (probe (throw (car probe) (eval-in-frame form index)))
+ (t (format nil "Cannot return from frame: ~S" frame))))
+ "return-from-frame is not implemented in this version of SCL.")))
+
+(defimplementation activate-stepping (frame)
+ (set-step-breakpoints (nth-frame frame)))
+
+(defimplementation sldb-break-on-return (frame)
+ (break-on-return (nth-frame frame)))
+
+;;; We set the breakpoint in the caller which might be a bit confusing.
+;;;
+(defun break-on-return (frame)
+ (let* ((caller (di:frame-down frame))
+ (cl (di:frame-code-location caller)))
+ (flet ((hook (frame bp)
+ (when (frame-pointer= frame caller)
+ (di:delete-breakpoint bp)
+ (signal-breakpoint bp frame))))
+ (let* ((info (ecase (di:code-location-kind cl)
+ ((:single-value-return :unknown-return) nil)
+ (:known-return (debug-function-returns
+ (di:frame-debug-function frame)))))
+ (bp (di:make-breakpoint #'hook cl :kind :code-location
+ :info info)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~A" caller))))))
+
+(defun frame-pointer= (frame1 frame2)
+ "Return true if the frame pointers of FRAME1 and FRAME2 are the same."
+ (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
+
+;;; The PC in escaped frames at a single-return-value point is
+;;; actually vm:single-value-return-byte-offset bytes after the
+;;; position given in the debug info. Here we try to recognize such
+;;; cases.
+;;;
+(defun next-code-locations (frame code-location)
+ "Like `debug::next-code-locations' but be careful in escaped frames."
+ (let ((next (debug::next-code-locations code-location)))
+ (flet ((adjust-pc ()
+ (let ((cl (di::copy-compiled-code-location code-location)))
+ (incf (di::compiled-code-location-pc cl)
+ vm:single-value-return-byte-offset)
+ cl)))
+ (cond ((and (di::compiled-frame-escaped frame)
+ (eq (di:code-location-kind code-location)
+ :single-value-return)
+ (= (length next) 1)
+ (di:code-location= (car next) (adjust-pc)))
+ (debug::next-code-locations (car next)))
+ (t
+ next)))))
+
+(defun set-step-breakpoints (frame)
+ (let ((cl (di:frame-code-location frame)))
+ (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
+ (error "Cannot step in elsewhere code"))
+ (let* ((debug::*bad-code-location-types*
+ (remove :call-site debug::*bad-code-location-types*))
+ (next (next-code-locations frame cl)))
+ (cond (next
+ (let ((steppoints '()))
+ (flet ((hook (bp-frame bp)
+ (signal-breakpoint bp bp-frame)
+ (mapc #'di:delete-breakpoint steppoints)))
+ (dolist (code-location next)
+ (let ((bp (di:make-breakpoint #'hook code-location
+ :kind :code-location)))
+ (di:activate-breakpoint bp)
+ (push bp steppoints))))))
+ (t
+ (break-on-return frame))))))
+
+
+;; XXX the return values at return breakpoints should be passed to the
+;; user hooks. debug-int.lisp should be changed to do this cleanly.
+
+;;; The sigcontext and the PC for a breakpoint invocation are not
+;;; passed to user hook functions, but we need them to extract return
+;;; values. So we advice di::handle-breakpoint and bind the values to
+;;; special variables.
+;;;
+(defvar *breakpoint-sigcontext*)
+(defvar *breakpoint-pc*)
+
+(defun sigcontext-object (sc index)
+ "Extract the lisp object in sigcontext SC at offset INDEX."
+ (kernel:make-lisp-obj (vm:ucontext-register sc index)))
+
+(defun known-return-point-values (sigcontext sc-offsets)
+ (let ((fp (system:int-sap (vm:ucontext-register sigcontext
+ vm::cfp-offset))))
+ (system:without-gcing
+ (loop for sc-offset across sc-offsets
+ collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
+
+;;; SCL returns the first few values in registers and the rest on
+;;; the stack. In the multiple value case, the number of values is
+;;; stored in a dedicated register. The values of the registers can be
+;;; accessed in the sigcontext for the breakpoint. There are 3 kinds
+;;; of return conventions: :single-value-return, :unknown-return, and
+;;; :known-return.
+;;;
+;;; The :single-value-return convention returns the value in a
+;;; register without setting the nargs registers.
+;;;
+;;; The :unknown-return variant is used for multiple values. A
+;;; :unknown-return point consists actually of 2 breakpoints: one for
+;;; the single value case and one for the general case. The single
+;;; value breakpoint comes vm:single-value-return-byte-offset after
+;;; the multiple value breakpoint.
+;;;
+;;; The :known-return convention is used by local functions.
+;;; :known-return is currently not supported because we don't know
+;;; where the values are passed.
+;;;
+(defun breakpoint-values (breakpoint)
+ "Return the list of return values for a return point."
+ (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
+ (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3)))
+ (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext))))
+ (cl (di:breakpoint-what breakpoint)))
+ (ecase (di:code-location-kind cl)
+ (:single-value-return
+ (list (1st sc)))
+ (:known-return
+ (let ((info (di:breakpoint-info breakpoint)))
+ (if (vectorp info)
+ (known-return-point-values sc info)
+ (progn
+ ;;(break)
+ (list "<<known-return convention not supported>>" info)))))
+ (:unknown-return
+ (let ((mv-return-pc (di::compiled-code-location-pc cl)))
+ (if (= mv-return-pc *breakpoint-pc*)
+ (mv-function-end-breakpoint-values sc)
+ (list (1st sc)))))))))
+
+(defun mv-function-end-breakpoint-values (sigcontext)
+ (let ((sym (find-symbol
+ (symbol-name '#:function-end-breakpoint-values/standard)
+ :debug-internals)))
+ (cond (sym (funcall sym sigcontext))
+ (t (di::get-function-end-breakpoint-values sigcontext)))))
+
+(defun debug-function-returns (debug-fun)
+ "Return the return style of DEBUG-FUN."
+ (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
+ (c::compiled-debug-function-returns cdfun)))
+
+(define-condition breakpoint (simple-condition)
+ ((message :initarg :message :reader breakpoint.message)
+ (values :initarg :values :reader breakpoint.values))
+ (:report (lambda (c stream) (princ (breakpoint.message c) stream))))
+
+#+nil
+(defimplementation condition-extras ((c breakpoint))
+ ;; simply pop up the source buffer
+ `((:short-frame-source 0)))
+
+(defun signal-breakpoint (breakpoint frame)
+ "Signal a breakpoint condition for BREAKPOINT in FRAME.
+Try to create a informative message."
+ (flet ((brk (values fstring &rest args)
+ (let ((msg (apply #'format nil fstring args))
+ (debug:*stack-top-hint* frame))
+ (break 'breakpoint :message msg :values values))))
+ (with-struct (di::breakpoint- kind what) breakpoint
+ (case kind
+ (:code-location
+ (case (di:code-location-kind what)
+ ((:single-value-return :known-return :unknown-return)
+ (let ((values (breakpoint-values breakpoint)))
+ (brk values "Return value: ~{~S ~}" values)))
+ (t
+ #+(or)
+ (when (eq (di:code-location-kind what) :call-site)
+ (call-site-function breakpoint frame))
+ (brk nil "Breakpoint: ~S ~S"
+ (di:code-location-kind what)
+ (di::compiled-code-location-pc what)))))
+ (:function-start
+ (brk nil "Function start breakpoint"))
+ (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
+
+#+nil
+(defimplementation sldb-break-at-start (fname)
+ (let ((debug-fun (di:function-debug-function (coerce fname 'function))))
+ (cond ((not debug-fun)
+ `(:error ,(format nil "~S has no debug-function" fname)))
+ (t
+ (flet ((hook (frame bp &optional args cookie)
+ (declare (ignore args cookie))
+ (signal-breakpoint bp frame)))
+ (let ((bp (di:make-breakpoint #'hook debug-fun
+ :kind :function-start)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
+
+(defun frame-cfp (frame)
+ "Return the Control-Stack-Frame-Pointer for FRAME."
+ (etypecase frame
+ (di::compiled-frame (di::frame-pointer frame))
+ ((or di::interpreted-frame null) -1)))
+
+(defun frame-ip (frame)
+ "Return the (absolute) instruction pointer and the relative pc of FRAME."
+ (if (not frame)
+ -1
+ (let ((debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((code-loc (di:frame-code-location frame))
+ (component (di::compiled-debug-function-component debug-fun))
+ (pc (di::compiled-code-location-pc code-loc))
+ (ip (sys:without-gcing
+ (sys:sap-int
+ (sys:sap+ (kernel:code-instructions component) pc)))))
+ (values ip pc)))
+ ((or di::bogus-debug-function di::interpreted-debug-function)
+ -1)))))
+
+(defun frame-registers (frame)
+ "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
+ (let* ((cfp (frame-cfp frame))
+ (csp (frame-cfp (di::frame-up frame)))
+ (ip (frame-ip frame))
+ (ocfp (frame-cfp (di::frame-down frame)))
+ (lra (frame-ip (di::frame-down frame))))
+ (values csp cfp ip ocfp lra)))
+
+(defun print-frame-registers (frame-number)
+ (let ((frame (di::frame-real-frame (nth-frame frame-number))))
+ (flet ((fixnum (p) (etypecase p
+ (integer p)
+ (sys:system-area-pointer (sys:sap-int p)))))
+ (apply #'format t "~
+CSP = ~X
+CFP = ~X
+IP = ~X
+OCFP = ~X
+LRA = ~X~%" (mapcar #'fixnum
+ (multiple-value-list (frame-registers frame)))))))
+
+
+(defimplementation disassemble-frame (frame-number)
+ "Return a string with the disassembly of frames code."
+ (print-frame-registers frame-number)
+ (terpri)
+ (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
+ (debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((component (di::compiled-debug-function-component debug-fun))
+ (fun (di:debug-function-function debug-fun)))
+ (if fun
+ (disassemble fun)
+ (disassem:disassemble-code-component component))))
+ (di::bogus-debug-function
+ (format t "~%[Disassembling bogus frames not implemented]")))))
+
+
+;;;; Inspecting
+
+(defconstant +lowtag-symbols+
+ '(vm:even-fixnum-type
+ vm:instance-pointer-type
+ vm:other-immediate-0-type
+ vm:list-pointer-type
+ vm:odd-fixnum-type
+ vm:function-pointer-type
+ vm:other-immediate-1-type
+ vm:other-pointer-type)
+ "Names of the constants that specify type tags.
+The `symbol-value' of each element is a type tag.")
+
+(defconstant +header-type-symbols+
+ (labels ((suffixp (suffix string)
+ (and (>= (length string) (length suffix))
+ (string= string suffix :start1 (- (length string)
+ (length suffix)))))
+ (header-type-symbol-p (x)
+ (and (suffixp (symbol-name '#:-type) (symbol-name x))
+ (not (member x +lowtag-symbols+))
+ (boundp x)
+ (typep (symbol-value x) 'fixnum))))
+ (remove-if-not #'header-type-symbol-p
+ (append (apropos-list (symbol-name '#:-type) :vm)
+ (apropos-list (symbol-name '#:-type) :bignum))))
+ "A list of names of the type codes in boxed objects.")
+
+(defimplementation describe-primitive-type (object)
+ (with-output-to-string (*standard-output*)
+ (let* ((lowtag (kernel:get-lowtag object))
+ (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
+ (format t "lowtag: ~A" lowtag-symbol)
+ (when (member lowtag (list vm:other-pointer-type
+ vm:function-pointer-type
+ vm:other-immediate-0-type
+ vm:other-immediate-1-type
+ ))
+ (let* ((type (kernel:get-type object))
+ (type-symbol (find type +header-type-symbols+
+ :key #'symbol-value)))
+ (format t ", type: ~A" type-symbol))))))
+
+(defmethod emacs-inspect ((o t))
+ (cond ((di::indirect-value-cell-p o)
+ `("Value: " (:value ,(c:value-cell-ref o))))
+ ((alien::alien-value-p o)
+ (inspect-alien-value o))
+ (t
+ (scl-inspect o))))
+
+(defun scl-inspect (o)
+ (destructuring-bind (text labeledp . parts)
+ (inspect::describe-parts o)
+ (list* (format nil "~A~%" text)
+ (if labeledp
+ (loop for (label . value) in parts
+ append (label-value-line label value))
+ (loop for value in parts for i from 0
+ append (label-value-line i value))))))
+
+(defmethod emacs-inspect ((o function))
+ (let ((header (kernel:get-type o)))
+ (cond ((= header vm:function-header-type)
+ (list* (format nil "~A is a function.~%" o)
+ (append (label-value-line*
+ ("Self" (kernel:%function-self o))
+ ("Next" (kernel:%function-next o))
+ ("Name" (kernel:%function-name o))
+ ("Arglist" (kernel:%function-arglist o))
+ ("Type" (kernel:%function-type o))
+ ("Code" (kernel:function-code-header o)))
+ (list
+ (with-output-to-string (s)
+ (disassem:disassemble-function o :stream s))))))
+ ((= header vm:closure-header-type)
+ (list* (format nil "~A is a closure.~%" o)
+ (append
+ (label-value-line "Function" (kernel:%closure-function o))
+ `("Environment:" (:newline))
+ (loop for i from 0 below (- (kernel:get-closure-length o)
+ (1- vm:closure-info-offset))
+ append (label-value-line
+ i (kernel:%closure-index-ref o i))))))
+ ((eval::interpreted-function-p o)
+ (scl-inspect o))
+ (t
+ (call-next-method)))))
+
+
+(defmethod emacs-inspect ((o kernel:code-component))
+ (append
+ (label-value-line*
+ ("code-size" (kernel:%code-code-size o))
+ ("entry-points" (kernel:%code-entry-points o))
+ ("debug-info" (kernel:%code-debug-info o))
+ ("trace-table-offset" (kernel:code-header-ref
+ o vm:code-trace-table-offset-slot)))
+ `("Constants:" (:newline))
+ (loop for i from vm:code-constants-offset
+ below (kernel:get-header-data o)
+ append (label-value-line i (kernel:code-header-ref o i)))
+ `("Code:" (:newline)
+ , (with-output-to-string (s)
+ (cond ((kernel:%code-debug-info o)
+ (disassem:disassemble-code-component o :stream s))
+ (t
+ (disassem:disassemble-memory
+ (disassem::align
+ (+ (logandc2 (kernel:get-lisp-obj-address o)
+ vm:lowtag-mask)
+ (* vm:code-constants-offset vm:word-bytes))
+ (ash 1 vm:lowtag-bits))
+ (ash (kernel:%code-code-size o) vm:word-shift)
+ :stream s)))))))
+
+(defmethod emacs-inspect ((o kernel:fdefn))
+ (label-value-line*
+ ("name" (kernel:fdefn-name o))
+ ("function" (kernel:fdefn-function o))
+ ("raw-addr" (sys:sap-ref-32
+ (sys:int-sap (kernel:get-lisp-obj-address o))
+ (* vm:fdefn-raw-addr-slot vm:word-bytes)))))
+
+(defmethod emacs-inspect ((o array))
+ (cond ((kernel:array-header-p o)
+ (list* (format nil "~A is an array.~%" o)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:rank (array-rank o))
+ (:fill-pointer (kernel:%array-fill-pointer o))
+ (:fill-pointer-p (kernel:%array-fill-pointer-p o))
+ (:elements (kernel:%array-available-elements o))
+ (:data (kernel:%array-data-vector o))
+ (:displacement (kernel:%array-displacement o))
+ (:displaced-p (kernel:%array-displaced-p o))
+ (:dimensions (array-dimensions o)))))
+ (t
+ (list* (format nil "~A is an simple-array.~%" o)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:length (length o)))))))
+
+(defmethod emacs-inspect ((o simple-vector))
+ (list* (format nil "~A is a vector.~%" o)
+ (append
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:length (c::vector-length o)))
+ (unless (eq (array-element-type o) 'nil)
+ (loop for i below (length o)
+ append (label-value-line i (aref o i)))))))
+
+(defun inspect-alien-record (alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (with-struct (alien::alien-record-type- kind name fields) type
+ (append
+ (label-value-line*
+ (:sap sap)
+ (:kind kind)
+ (:name name))
+ (loop for field in fields
+ append (let ((slot (alien::alien-record-field-name field)))
+ (label-value-line slot (alien:slot alien slot))))))))
+
+(defun inspect-alien-pointer (alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (label-value-line*
+ (:sap sap)
+ (:type type)
+ (:to (alien::deref alien)))))
+
+(defun inspect-alien-value (alien)
+ (typecase (alien::alien-value-type alien)
+ (alien::alien-record-type (inspect-alien-record alien))
+ (alien::alien-pointer-type (inspect-alien-pointer alien))
+ (t (scl-inspect alien))))
+
+;;;; Profiling
+(defimplementation profile (fname)
+ (eval `(profile:profile ,fname)))
+
+(defimplementation unprofile (fname)
+ (eval `(profile:unprofile ,fname)))
+
+(defimplementation unprofile-all ()
+ (eval `(profile:unprofile))
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (eval `(profile:report-time)))
+
+(defimplementation profile-reset ()
+ (eval `(profile:reset-time))
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ profile:*timed-functions*)
+
+(defimplementation profile-package (package callers methods)
+ (profile:profile-all :package package
+ :callers-p callers
+ #+nil :methods #+nil methods))
+
+
+;;;; Multiprocessing
+
+(defimplementation spawn (fn &key name)
+ (thread:thread-create fn :name (or name "Anonymous")))
+
+(defvar *thread-id-counter* 0)
+(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter"))
+
+(defimplementation thread-id (thread)
+ (thread:with-lock-held (*thread-id-counter-lock*)
+ (or (getf (thread:thread-plist thread) 'id)
+ (setf (getf (thread:thread-plist thread) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (block find-thread
+ (thread:map-over-threads
+ #'(lambda (thread)
+ (when (eql (getf (thread:thread-plist thread) 'id) id)
+ (return-from find-thread thread))))))
+
+(defimplementation thread-name (thread)
+ (princ-to-string (thread:thread-name thread)))
+
+(defimplementation thread-status (thread)
+ (let ((dynamic-values (thread::thread-dynamic-values thread)))
+ (if (zerop dynamic-values) "Exited" "Running")))
+
+(defimplementation make-lock (&key name)
+ (thread:make-lock name))
+
+(defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (thread:with-lock-held (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ thread:*thread*)
+
+(defimplementation all-threads ()
+ (let ((all-threads nil))
+ (thread:map-over-threads #'(lambda (thread) (push thread all-threads)))
+ all-threads))
+
+(defimplementation interrupt-thread (thread fn)
+ (thread:thread-interrupt thread #'(lambda ()
+ (sys:with-interrupts
+ (funcall fn)))))
+
+(defimplementation kill-thread (thread)
+ (thread:destroy-thread thread))
+
+(defimplementation thread-alive-p (thread)
+ (not (zerop (thread::thread-dynamic-values thread))))
+
+(defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil))
+
+(defstruct (mailbox)
+ (lock (thread:make-lock "Thread mailbox" :type :error-check
+ :interruptible nil)
+ :type thread:error-check-lock)
+ (queue '() :type list))
+
+(defun mailbox (thread)
+ "Return 'thread's mailbox."
+ (sys:without-interrupts
+ (thread:with-lock-held (*mailbox-lock*)
+ (or (getf (thread:thread-plist thread) 'mailbox)
+ (setf (getf (thread:thread-plist thread) 'mailbox)
+ (make-mailbox))))))
+
+(defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (lock (mailbox-lock mbox)))
+ (sys:without-interrupts
+ (thread:with-lock-held (lock "Mailbox Send")
+ (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
+ (list message)))))
+ (mp:process-wakeup thread)))
+
+#+nil
+(defimplementation receive ()
+ (receive-if (constantly t)))
+
+(defimplementation receive-if (test &optional timeout)
+ (let ((mbox (mailbox thread:*thread*)))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (sys:without-interrupts
+ (mp:with-lock-held ((mailbox-lock mbox))
+ (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)))
+ (mp:process-wait-with-timeout
+ "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox)))))))
+
+
+
+(defimplementation emacs-connected ())
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;Trace implementations
+;; In SCL, we have:
+;; (trace <name>)
+;; (trace (method <name> <qualifier>? (<specializer>+)))
+;; (trace :methods t '<name>) ;;to trace all methods of the gf <name>
+;; <name> can be a normal name or a (setf name)
+
+(defun tracedp (spec)
+ (member spec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (spec &rest options)
+ (cond ((tracedp spec)
+ (eval `(untrace ,spec))
+ (format nil "~S is now untraced." spec))
+ (t
+ (eval `(trace ,spec ,@options))
+ (format nil "~S is now traced." spec))))
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ ((:defgeneric)
+ (let ((name (second spec)))
+ (toggle-trace-aux name :methods name)))
+ ((:defmethod)
+ nil)
+ ((:call)
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux (process-fspec callee)
+ :wherein (list (process-fspec caller)))))))
+
+(defun process-fspec (fspec)
+ (cond ((consp fspec)
+ (ecase (first fspec)
+ ((:defun :defgeneric) (second fspec))
+ ((:defmethod)
+ `(method ,(second fspec) ,@(third fspec) ,(fourth fspec)))
+ ;; this isn't actually supported
+ ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
+ ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
+ (t
+ fspec)))
+
+;;; Weak datastructures
+
+;;; Not implemented in SCL.
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-p t args))
diff --git a/vim/bundle/slimv/slime/swank/source-file-cache.lisp b/vim/bundle/slimv/slime/swank/source-file-cache.lisp
new file mode 100644
index 0000000..ac48acf
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/source-file-cache.lisp
@@ -0,0 +1,136 @@
+;;;; Source-file cache
+;;;
+;;; To robustly find source locations in CMUCL and SBCL it's useful to
+;;; have the exact source code that the loaded code was compiled from.
+;;; In this source we can accurately find the right location, and from
+;;; that location we can extract a "snippet" of code to show what the
+;;; definition looks like. Emacs can use this snippet in a best-match
+;;; search to locate the right definition, which works well even if
+;;; the buffer has been modified.
+;;;
+;;; The idea is that if a definition previously started with
+;;; `(define-foo bar' then it probably still does.
+;;;
+;;; Whenever we see that the file on disk has the same
+;;; `file-write-date' as a location we're looking for we cache the
+;;; whole file inside Lisp. That way we will still have the matching
+;;; version even if the file is later modified on disk. If the file is
+;;; later recompiled and reloaded then we replace our cache entry.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+
+(defpackage swank/source-file-cache
+ (:use cl)
+ (:import-from swank/backend
+ defimplementation buffer-first-change
+ guess-external-format
+ find-external-format)
+ (:export
+ get-source-code
+ source-cache-get ;FIXME: isn't it odd that both are exported?
+
+ *source-snippet-size*
+ read-snippet
+ read-snippet-from-string
+ ))
+
+(in-package swank/source-file-cache)
+
+(defvar *cache-sourcecode* t
+ "When true complete source files are cached.
+The cache is used to keep known good copies of the source text which
+correspond to the loaded code. Finding definitions is much more
+reliable when the exact source is available, so we cache it in case it
+gets edited on disk later.")
+
+(defvar *source-file-cache* (make-hash-table :test 'equal)
+ "Cache of source file contents.
+Maps from truename to source-cache-entry structure.")
+
+(defstruct (source-cache-entry
+ (:conc-name source-cache-entry.)
+ (:constructor make-source-cache-entry (text date)))
+ text date)
+
+(defimplementation buffer-first-change (filename)
+ "Load a file into the cache when the user modifies its buffer.
+This is a win if the user then saves the file and tries to M-. into it."
+ (unless (source-cached-p filename)
+ (ignore-errors
+ (source-cache-get filename (file-write-date filename))))
+ nil)
+
+(defun get-source-code (filename code-date)
+ "Return the source code for FILENAME as written on DATE in a string.
+If the exact version cannot be found then return the current one from disk."
+ (or (source-cache-get filename code-date)
+ (read-file filename)))
+
+(defun source-cache-get (filename date)
+ "Return the source code for FILENAME as written on DATE in a string.
+Return NIL if the right version cannot be found."
+ (when *cache-sourcecode*
+ (let ((entry (gethash filename *source-file-cache*)))
+ (cond ((and entry (equal date (source-cache-entry.date entry)))
+ ;; Cache hit.
+ (source-cache-entry.text entry))
+ ((or (null entry)
+ (not (equal date (source-cache-entry.date entry))))
+ ;; Cache miss.
+ (if (equal (file-write-date filename) date)
+ ;; File on disk has the correct version.
+ (let ((source (read-file filename)))
+ (setf (gethash filename *source-file-cache*)
+ (make-source-cache-entry source date))
+ source)
+ nil))))))
+
+(defun source-cached-p (filename)
+ "Is any version of FILENAME in the source cache?"
+ (if (gethash filename *source-file-cache*) t))
+
+(defun read-file (filename)
+ "Return the entire contents of FILENAME as a string."
+ (with-open-file (s filename :direction :input
+ :external-format (or (guess-external-format filename)
+ (find-external-format "latin-1")
+ :default))
+ (let* ((string (make-string (file-length s)))
+ (length (read-sequence string s)))
+ (subseq string 0 length))))
+
+;;;; Snippets
+
+(defvar *source-snippet-size* 256
+ "Maximum number of characters in a snippet of source code.
+Snippets at the beginning of definitions are used to tell Emacs what
+the definitions looks like, so that it can accurately find them by
+text search.")
+
+(defun read-snippet (stream &optional position)
+ "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM.
+If POSITION is given, set the STREAM's file position first."
+ (when position
+ (file-position stream position))
+ #+sbcl (skip-comments-and-whitespace stream)
+ (read-upto-n-chars stream *source-snippet-size*))
+
+(defun read-snippet-from-string (string &optional position)
+ (with-input-from-string (s string)
+ (read-snippet s position)))
+
+(defun skip-comments-and-whitespace (stream)
+ (case (peek-char nil stream)
+ ((#\Space #\Tab #\Newline #\Linefeed #\Page)
+ (read-char stream)
+ (skip-comments-and-whitespace stream))
+ (#\;
+ (read-line stream)
+ (skip-comments-and-whitespace stream))))
+
+(defun read-upto-n-chars (stream n)
+ "Return a string of upto N chars from STREAM."
+ (let* ((string (make-string n))
+ (chars (read-sequence string stream)))
+ (subseq string 0 chars)))
diff --git a/vim/bundle/slimv/slime/swank/source-path-parser.lisp b/vim/bundle/slimv/slime/swank/source-path-parser.lisp
new file mode 100644
index 0000000..bb9c35c
--- /dev/null
+++ b/vim/bundle/slimv/slime/swank/source-path-parser.lisp
@@ -0,0 +1,239 @@
+;;;; Source-paths
+
+;;; CMUCL/SBCL use a data structure called "source-path" to locate
+;;; subforms. The compiler assigns a source-path to each form in a
+;;; compilation unit. Compiler notes usually contain the source-path
+;;; of the error location.
+;;;
+;;; Compiled code objects don't contain source paths, only the
+;;; "toplevel-form-number" and the (sub-) "form-number". To get from
+;;; the form-number to the source-path we need the entire toplevel-form
+;;; (i.e. we have to read the source code). CMUCL has already some
+;;; utilities to do this translation, but we use some extended
+;;; versions, because we need more exact position info. Apparently
+;;; Hemlock is happy with the position of the toplevel-form; we also
+;;; need the position of subforms.
+;;;
+;;; We use a special readtable to get the positions of the subforms.
+;;; The readtable stores the start and end position for each subform in
+;;; hashtable for later retrieval.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+
+;;; Taken from swank-cmucl.lisp, by Helmut Eller
+
+(defpackage swank/source-path-parser
+ (:use cl)
+ (:export
+ read-source-form
+ source-path-string-position
+ source-path-file-position
+ source-path-source-position
+
+ sexp-in-bounds-p
+ sexp-ref)
+ (:shadow ignore-errors))
+
+(in-package swank/source-path-parser)
+
+;; Some test to ensure the required conformance
+(let ((rt (copy-readtable nil)))
+ (assert (or (not (get-macro-character #\space rt))
+ (nth-value 1 (get-macro-character #\space rt))))
+ (assert (not (get-macro-character #\\ rt))))
+
+(eval-when (:compile-toplevel)
+ (defmacro ignore-errors (&rest forms)
+ ;;`(progn . ,forms) ; for debugging
+ `(cl:ignore-errors . ,forms)))
+
+(defun make-sharpdot-reader (orig-sharpdot-reader)
+ (lambda (s c n)
+ ;; We want things like M-. to work regardless of any #.-fu in
+ ;; the source file that is to be visited. (For instance, when a
+ ;; file contains #. forms referencing constants that do not
+ ;; currently exist in the image.)
+ (ignore-errors (funcall orig-sharpdot-reader s c n))))
+
+(defun make-source-recorder (fn source-map)
+ "Return a macro character function that does the same as FN, but
+additionally stores the result together with the stream positions
+before and after of calling FN in the hashtable SOURCE-MAP."
+ (lambda (stream char)
+ (let ((start (1- (file-position stream)))
+ (values (multiple-value-list (funcall fn stream char)))
+ (end (file-position stream)))
+ #+(or)
+ (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%"
+ start values end (char-code char) char)
+ (when values
+ (destructuring-bind (&optional existing-start &rest existing-end)
+ (car (gethash (car values) source-map))
+ ;; Some macros may return what a sub-call to another macro
+ ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice,
+ ;; once from #\# and once from #\(. If the saved form
+ ;; is a subform, don't save it again.
+ (unless (and existing-start existing-end
+ (<= start existing-start end)
+ (<= start existing-end end))
+ (push (cons start end) (gethash (car values) source-map)))))
+ (values-list values))))
+
+(defun make-source-recording-readtable (readtable source-map)
+ (declare (type readtable readtable) (type hash-table source-map))
+ "Return a source position recording copy of READTABLE.
+The source locations are stored in SOURCE-MAP."
+ (flet ((install-special-sharpdot-reader (rt)
+ (let ((fun (ignore-errors
+ (get-dispatch-macro-character #\# #\. rt))))
+ (when fun
+ (let ((wrapper (make-sharpdot-reader fun)))
+ (set-dispatch-macro-character #\# #\. wrapper rt)))))
+ (install-wrappers (rt)
+ (dotimes (code 128)
+ (let ((char (code-char code)))
+ (multiple-value-bind (fun nt) (get-macro-character char rt)
+ (when fun
+ (let ((wrapper (make-source-recorder fun source-map)))
+ (set-macro-character char wrapper nt rt))))))))
+ (let ((rt (copy-readtable readtable)))
+ (install-special-sharpdot-reader rt)
+ (install-wrappers rt)
+ rt)))
+
+;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning.
+;; Should be possible as we only need the right "list structure" and
+;; not the right atoms.
+(defun read-and-record-source-map (stream)
+ "Read the next object from STREAM.
+Return the object together with a hashtable that maps
+subexpressions of the object to stream positions."
+ (let* ((source-map (make-hash-table :test #'eq))
+ (*readtable* (make-source-recording-readtable *readtable* source-map))
+ (*read-suppress* nil)
+ (start (file-position stream))
+ (form (ignore-errors (read stream)))
+ (end (file-position stream)))
+ ;; ensure that at least FORM is in the source-map
+ (unless (gethash form source-map)
+ (push (cons start end) (gethash form source-map)))
+ (values form source-map)))
+
+(defun starts-with-p (string prefix)
+ (declare (type string string prefix))
+ (not (mismatch string prefix
+ :end1 (min (length string) (length prefix))
+ :test #'char-equal)))
+
+(defun extract-package (line)
+ (declare (type string line))
+ (let ((name (cadr (read-from-string line))))
+ (find-package name)))
+
+#+(or)
+(progn
+ (assert (extract-package "(in-package cl)"))
+ (assert (extract-package "(cl:in-package cl)"))
+ (assert (extract-package "(in-package \"CL\")"))
+ (assert (extract-package "(in-package #:cl)")))
+
+;; FIXME: do something cleaner than this.
+(defun readtable-for-package (package)
+ ;; KLUDGE: due to the load order we can't reference the swank
+ ;; package.
+ (funcall (read-from-string "swank::guess-buffer-readtable")
+ (string-upcase (package-name package))))
+
+;; Search STREAM for a "(in-package ...)" form. Use that to derive
+;; the values for *PACKAGE* and *READTABLE*.
+;;
+;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends
+;; use the same heuristic and to avoid the need to access
+;; swank::guess-buffer-readtable from here.
+(defun guess-reader-state (stream)
+ (let* ((point (file-position stream))
+ (pkg *package*))
+ (file-position stream 0)
+ (loop for line = (read-line stream nil nil) do
+ (when (not line) (return))
+ (when (or (starts-with-p line "(in-package ")
+ (starts-with-p line "(cl:in-package "))
+ (let ((p (extract-package line)))
+ (when p (setf pkg p)))
+ (return)))
+ (file-position stream point)
+ (values (readtable-for-package pkg) pkg)))
+
+(defun skip-whitespace (stream)
+ (peek-char t stream nil nil))
+
+;; Skip over N toplevel forms.
+(defun skip-toplevel-forms (n stream)
+ (let ((*read-suppress* t))
+ (dotimes (i n)
+ (read stream))
+ (skip-whitespace stream)))
+
+(defun read-source-form (n stream)
+ "Read the Nth toplevel form number with source location recording.
+Return the form and the source-map."
+ (multiple-value-bind (*readtable* *package*) (guess-reader-state stream)
+ (skip-toplevel-forms n stream)
+ (read-and-record-source-map stream)))
+
+(defun source-path-stream-position (path stream)
+ "Search the source-path PATH in STREAM and return its position."
+ (check-source-path path)
+ (destructuring-bind (tlf-number . path) path
+ (multiple-value-bind (form source-map) (read-source-form tlf-number stream)
+ (source-path-source-position (cons 0 path) form source-map))))
+
+(defun check-source-path (path)
+ (unless (and (consp path)
+ (every #'integerp path))
+ (error "The source-path ~S is not valid." path)))
+
+(defun source-path-string-position (path string)
+ (with-input-from-string (s string)
+ (source-path-stream-position path s)))
+
+(defun source-path-file-position (path filename)
+ ;; We go this long way round, and don't directly operate on the file
+ ;; stream because FILE-POSITION (used above) is not totally savy even
+ ;; on file character streams; on SBCL, FILE-POSITION returns the binary
+ ;; offset, and not the character offset---screwing up on Unicode.
+ (let ((toplevel-number (first path))
+ (buffer))
+ (with-open-file (file filename)
+ (skip-toplevel-forms (1+ toplevel-number) file)
+ (let ((endpos (file-position file)))
+ (setq buffer (make-array (list endpos) :element-type 'character
+ :initial-element #\Space))
+ (assert (file-position file 0))
+ (read-sequence buffer file :end endpos)))
+ (source-path-string-position path buffer)))
+
+(defgeneric sexp-in-bounds-p (sexp i)
+ (:method ((list list) i)
+ (< i (loop for e on list
+ count t)))
+ (:method ((sexp t) i) nil))
+
+(defgeneric sexp-ref (sexp i)
+ (:method ((s list) i) (elt s i)))
+
+(defun source-path-source-position (path form source-map)
+ "Return the start position of PATH from FORM and SOURCE-MAP. All
+subforms along the path are considered and the start and end position
+of the deepest (i.e. smallest) possible form is returned."
+ ;; compute all subforms along path
+ (let ((forms (loop for i in path
+ for f = form then (if (sexp-in-bounds-p f i)
+ (sexp-ref f i))
+ collect f)))
+ ;; select the first subform present in source-map
+ (loop for form in (nreverse forms)
+ for ((start . end) . rest) = (gethash form source-map)
+ when (and start end (not rest))
+ return (return (values start end)))))
diff --git a/vim/bundle/slimv/slime/xref.lisp b/vim/bundle/slimv/slime/xref.lisp
new file mode 100644
index 0000000..e09a150
--- /dev/null
+++ b/vim/bundle/slimv/slime/xref.lisp
@@ -0,0 +1,2906 @@
+;;; -*- Mode: LISP; Package: XREF; Syntax: Common-lisp; -*-
+;;; Mon Jan 21 16:21:20 1991 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU>
+;;; xref.lisp
+
+;;; ****************************************************************
+;;; List Callers: A Static Analysis Cross Referencing Tool for Lisp
+;;; ****************************************************************
+;;;
+;;; The List Callers system is a portable Common Lisp cross referencing
+;;; utility. It grovels over a set of files and compiles a database of the
+;;; locations of all references for each symbol used in the files.
+;;; List Callers is similar to the Symbolics Who-Calls and the
+;;; Xerox Masterscope facilities.
+;;;
+;;; When you change a function or variable definition, it can be useful
+;;; to know its callers, in order to update each of them to the new
+;;; definition. Similarly, having a graphic display of the structure
+;;; (e.g., call graph) of a program can help make undocumented code more
+;;; understandable. This static code analyzer facilitates both capabilities.
+;;; The database compiled by xref is suitable for viewing by a graphical
+;;; browser. (Note: the reference graph is not necessarily a DAG. Since many
+;;; graphical browsers assume a DAG, this will lead to infinite loops.
+;;; Some code which is useful in working around this problem is included,
+;;; as well as a sample text-indenting outliner and an interface to Bates'
+;;; PSGraph Postscript Graphing facility.)
+;;;
+;;; Written by Mark Kantrowitz, July 1990.
+;;;
+;;; Address: School of Computer Science
+;;; Carnegie Mellon University
+;;; Pittsburgh, PA 15213
+;;;
+;;; Copyright (c) 1990. All rights reserved.
+;;;
+;;; See general license below.
+;;;
+
+;;; ****************************************************************
+;;; General License Agreement and Lack of Warranty *****************
+;;; ****************************************************************
+;;;
+;;; This software is distributed in the hope that it will be useful (both
+;;; in and of itself and as an example of lisp programming), but WITHOUT
+;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for
+;;; the consequences of using it or for whether it serves any particular
+;;; purpose or works at all. No warranty is made about the software or its
+;;; performance.
+;;;
+;;; Use and copying of this software and the preparation of derivative
+;;; works based on this software are permitted, so long as the following
+;;; conditions are met:
+;;; o The copyright notice and this entire notice are included intact
+;;; and prominently carried on all copies and supporting documentation.
+;;; o No fees or compensation are charged for use, copies, or
+;;; access to this software. You may charge a nominal
+;;; distribution fee for the physical act of transferring a
+;;; copy, but you may not charge for the program itself.
+;;; o If you modify this software, you must cause the modified
+;;; file(s) to carry prominent notices (a Change Log)
+;;; describing the changes, who made the changes, and the date
+;;; of those changes.
+;;; o Any work distributed or published that in whole or in part
+;;; contains or is a derivative of this software or any part
+;;; thereof is subject to the terms of this agreement. The
+;;; aggregation of another unrelated program with this software
+;;; or its derivative on a volume of storage or distribution
+;;; medium does not bring the other program under the scope
+;;; of these terms.
+;;; o Permission is granted to manufacturers and distributors of
+;;; lisp compilers and interpreters to include this software
+;;; with their distribution.
+;;;
+;;; This software is made available AS IS, and is distributed without
+;;; warranty of any kind, either expressed or implied.
+;;;
+;;; In no event will the author(s) or their institutions be liable to you
+;;; for damages, including lost profits, lost monies, or other special,
+;;; incidental or consequential damages arising out of or in connection
+;;; with the use or inability to use (including but not limited to loss of
+;;; data or data being rendered inaccurate or losses sustained by third
+;;; parties or a failure of the program to operate as documented) the
+;;; program, even if you have been advised of the possibility of such
+;;; damanges, or for any claim by any other party, whether in an action of
+;;; contract, negligence, or other tortious action.
+;;;
+;;; The current version of this software and a variety of related utilities
+;;; may be obtained by anonymous ftp from ftp.cs.cmu.edu in the directory
+;;; user/ai/lang/lisp/code/tools/xref/
+;;;
+;;; Please send bug reports, comments, questions and suggestions to
+;;; mkant@cs.cmu.edu. We would also appreciate receiving any changes
+;;; or improvements you may make.
+;;;
+;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list,
+;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email
+;;; address, and affiliation. This mailing list is primarily for
+;;; notification about major updates, bug fixes, and additions to the lisp
+;;; utilities collection. The mailing list is intended to have low traffic.
+;;;
+
+;;; ********************************
+;;; Change Log *********************
+;;; ********************************
+;;;
+;;; 27-FEB-91 mk Added insert arg to psgraph-xref to allow the postscript
+;;; graphs to be inserted in Scribe documents.
+;;; 21-FEB-91 mk Added warning if not compiled.
+;;; 07-FEB-91 mk Fixed bug in record-callers with regard to forms at
+;;; toplevel.
+;;; 21-JAN-91 mk Added file xref-test.lisp to test xref.
+;;; 16-JAN-91 mk Added definition WHO-CALLS to parallel the Symbolics syntax.
+;;; 16-JAN-91 mk Added macroexpansion capability to record-callers. Also
+;;; added parameter *handle-macro-forms*, defaulting to T.
+;;; 16-JAN-91 mk Modified print-caller-tree and related functions
+;;; to allow the user to specify root nodes. If the user
+;;; doesn't specify them, it will default to all root
+;;; nodes, as before.
+;;; 16-JAN-91 mk Added parameter *default-graphing-mode* to specify
+;;; the direction of the graphing. Either :call-graph,
+;;; where the children of a node are those functions called
+;;; by the node, or :caller-graph where the children of a
+;;; node are the callers of the node. :call-graph is the
+;;; default.
+;;; 16-JAN-91 mk Added parameter *indent-amount* to control the indentation
+;;; in print-indented-tree.
+;;; 16-JUL-90 mk Functions with argument lists of () were being ignored
+;;; because of a (when form) wrapped around the body of
+;;; record-callers. Then intent of (when form) was as an extra
+;;; safeguard against infinite looping. This wasn't really
+;;; necessary, so it has been removed.
+;;; 16-JUL-90 mk PSGraph-XREF now has keyword arguments, instead of
+;;; optionals.
+;;; 16-JUL-90 mk Added PRINT-CLASS-HIERARCHY to use psgraph to graph the
+;;; CLOS class hierarchy. This really doesn't belong here,
+;;; and should be moved to psgraph.lisp as an example of how
+;;; to use psgraph.
+;;; 16-JUL-90 mk Fixed several caller patterns. The pattern for member
+;;; had an error which caused many references to be missed.
+;;; 16-JUL-90 mk Added ability to save/load processed databases.
+;;; 5-JUL-91 mk Fixed warning of needing compilation to occur only when the
+;;; source is loaded.
+;;; 20-SEP-93 mk Added fix from Peter Norvig to allow Xref to xref itself.
+;;; The arg to macro-function must be a symbol.
+;;; 7-APR-12 heller Break lines at 80 columns.
+
+;;; ********************************
+;;; To Do **************************
+;;; ********************************
+;;;
+;;; Verify that:
+;;; o null forms don't cause it to infinite loop.
+;;; o nil matches against null argument lists.
+;;; o declarations and doc are being ignored.
+;;;
+;;; Would be nice if in addition to showing callers of a function, it
+;;; displayed the context of the calls to the function (e.g., the
+;;; immediately surrounding form). This entails storing entries of
+;;; the form (symbol context*) in the database and augmenting
+;;; record-callers to keep the context around. The only drawbacks is
+;;; that it would cons a fair bit. If we do this, we should store
+;;; additional information as well in the database, such as the caller
+;;; pattern type (e.g., variable vs. function).
+;;;
+;;; Write a translator from BNF (at least as much of BNF as is used
+;;; in CLtL2), to the format used here.
+;;;
+;;; Should automatically add new patterns for new functions and macros
+;;; based on their arglists. Probably requires much more than this
+;;; simple code walker, so there isn't much we can do.
+;;;
+;;; Defmacro is a problem, because it often hides internal function
+;;; calls within backquote and quote, which we normally ignore. If
+;;; we redefine QUOTE's pattern so that it treats the arg like a FORM,
+;;; we'll probably get them (though maybe the syntax will be mangled),
+;;; but most likely a lot of spurious things as well.
+;;;
+;;; Define an operation for Defsystem which will run XREF-FILE on the
+;;; files of the system. Or yet simpler, when XREF sees a LOAD form
+;;; for which the argument is a string, tries to recursively call
+;;; XREF-FILE on the specified file. Then one could just XREF-FILE
+;;; the file which loads the system. (This should be a program
+;;; parameter.)
+;;;
+;;; Have special keywords which the user may place in a file to have
+;;; XREF-FILE ignore a region.
+;;;
+;;; Should we distinguish flet and labels from defun? I.e., note that
+;;; flet's definitions are locally defined, instead of just lumping
+;;; them in with regular definitions.
+;;;
+;;; Add patterns for series, loop macro.
+;;;
+;;; Need to integrate the variable reference database with the other
+;;; databases, yet maintain separation. So we can distinguish all
+;;; the different types of variable and function references, without
+;;; multiplying databases.
+;;;
+;;; Would pay to comment record-callers and record-callers* in more
+;;; depth.
+;;;
+;;; (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT)
+
+;;; ********************************
+;;; Notes **************************
+;;; ********************************
+;;;
+;;; XREF has been tested (successfully) in the following lisps:
+;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
+;;; Macintosh Allegro Common Lisp (1.3.2)
+;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90)
+;;; Lucid CL (Version 2.1 6-DEC-87)
+;;;
+;;; XREF has been tested (unsuccessfully) in the following lisps:
+;;; Ibuki Common Lisp (01/01, October 15, 1987)
+;;; - if interpreted, runs into stack overflow
+;;; - does not compile (tried ibcl on Suns, PMAXes and RTs)
+;;; seems to be due to a limitation in the c compiler.
+;;;
+;;; XREF needs to be tested in the following lisps:
+;;; Symbolics Common Lisp (8.0)
+;;; Lucid Common Lisp (3.0, 4.0)
+;;; KCL (June 3, 1987 or later)
+;;; AKCL (1.86, June 30, 1987 or later)
+;;; TI (Release 4.1 or later)
+;;; Golden Common Lisp (3.1 IBM-PC)
+;;; VAXLisp (2.0, 3.1)
+;;; HP Common Lisp (same as Lucid?)
+;;; Procyon Common Lisp
+
+
+;;; ****************************************************************
+;;; Documentation **************************************************
+;;; ****************************************************************
+;;;
+;;; XREF analyzes a user's program, determining which functions call a
+;;; given function, and the location of where variables are bound/assigned
+;;; and used. The user may retrieve this information for either a single
+;;; symbol, or display the call graph of portions of the program
+;;; (including the entire program). This allows the programmer to debug
+;;; and document the program's structure.
+;;;
+;;; XREF is primarily intended for analyzing large programs, where it is
+;;; difficult, if not impossible, for the programmer to grasp the structure
+;;; of the whole program. Nothing precludes using XREF for smaller programs,
+;;; where it can be useful for inspecting the relationships between pieces
+;;; of the program and for documenting the program.
+;;;
+;;; Two aspects of the Lisp programming language greatly simplify the
+;;; analysis of Lisp programs:
+;;; o Lisp programs are naturally represented as data.
+;;; Successive definitions from a file are easily read in
+;;; as list structure.
+;;; o The basic syntax of Lisp is uniform. A list program
+;;; consists of a set of nested forms, where each form is
+;;; a list whose car is a tag (e.g., function name) that
+;;; specifies the structure of the rest of the form.
+;;; Thus Lisp programs, when represented as data, can be considered to be
+;;; parse trees. Given a grammar of syntax patterns for the language, XREF
+;;; recursively descends the parse tree for a given definition, computing
+;;; a set of relations that hold for the definition at each node in the
+;;; tree. For example, one kind of relation is that the function defined
+;;; by the definition calls the functions in its body. The relations are
+;;; stored in a database for later examination by the user.
+;;;
+;;; While XREF currently only works for programs written in Lisp, it could
+;;; be extended to other programming languages by writing a function to
+;;; generate parse trees for definitions in that language, and a core
+;;; set of patterns for the language's syntax.
+;;;
+;;; Since XREF normally does a static syntactic analysis of the program,
+;;; it does not detect references due to the expansion of a macro definition.
+;;; To do this in full generality XREF would have to have knowledge about the
+;;; semantics of the program (e.g., macros which call other functions to
+;;; do the expansion). This entails either modifying the compiler to
+;;; record the relationships (e.g., Symbolics Who-Calls Database) or doing
+;;; a walk of loaded code and macroexpanding as needed (PCL code walker).
+;;; The former is not portable, while the latter requires that the code
+;;; used by macros be loaded and in working order. On the other hand, then
+;;; we would need no special knowledge about macros (excluding the 24 special
+;;; forms of Lisp).
+;;;
+;;; Parameters may be set to enable macro expansion in XREF. Then XREF
+;;; will expand any macros for which it does not have predefined patterns.
+;;; (For example, most Lisps will implement dolist as a macro. Since XREF
+;;; has a pattern defined for dolist, it will not call macroexpand-1 on
+;;; a form whose car is dolist.) For this to work properly, the code must
+;;; be loaded before being processed by XREF, and XREF's parameters should
+;;; be set so that it processes forms in their proper packages.
+;;;
+;;; If macro expansion is disabled, the default rules for handling macro
+;;; references may not be sufficient for some user-defined macros, because
+;;; macros allow a variety of non-standard syntactic extensions to the
+;;; language. In this case, the user may specify additional templates in
+;;; a manner similar to that in which the core Lisp grammar was specified.
+;;;
+
+
+;;; ********************************
+;;; User Guide *********************
+;;; ********************************
+;;; -----
+;;; The following functions are called to cross reference the source files.
+;;;
+;;; XREF-FILES (&rest files) [FUNCTION]
+;;; Grovels over the lisp code located in source file FILES, using
+;;; xref-file.
+;;;
+;;; XREF-FILE (filename &optional clear-tables verbose) [Function]
+;;; Cross references the function and variable calls in FILENAME by
+;;; walking over the source code located in the file. Defaults type of
+;;; filename to ".lisp". Chomps on the code using record-callers and
+;;; record-callers*. If CLEAR-TABLES is T (the default), it clears the
+;;; callers database before processing the file. Specify CLEAR-TABLES as
+;;; nil to append to the database. If VERBOSE is T (the default), prints
+;;; out the name of the file, one progress dot for each form processed,
+;;; and the total number of forms.
+;;;
+;;; -----
+;;; The following functions display information about the uses of the
+;;; specified symbol as a function, variable, or constant.
+;;;
+;;; LIST-CALLERS (symbol) [FUNCTION]
+;;; Lists all functions which call SYMBOL as a function (function
+;;; invocation).
+;;;
+;;; LIST-READERS (symbol) [FUNCTION]
+;;; Lists all functions which refer to SYMBOL as a variable
+;;; (variable reference).
+;;;
+;;; LIST-SETTERS (symbol) [FUNCTION]
+;;; Lists all functions which bind/set SYMBOL as a variable
+;;; (variable mutation).
+;;;
+;;; LIST-USERS (symbol) [FUNCTION]
+;;; Lists all functions which use SYMBOL as a variable or function.
+;;;
+;;; WHO-CALLS (symbol &optional how) [FUNCTION]
+;;; Lists callers of symbol. HOW may be :function, :reader, :setter,
+;;; or :variable."
+;;;
+;;; WHAT-FILES-CALL (symbol) [FUNCTION]
+;;; Lists names of files that contain uses of SYMBOL
+;;; as a function, variable, or constant.
+;;;
+;;; SOURCE-FILE (symbol) [FUNCTION]
+;;; Lists the names of files in which SYMBOL is defined/used.
+;;;
+;;; LIST-CALLEES (symbol) [FUNCTION]
+;;; Lists names of functions and variables called by SYMBOL.
+;;;
+;;; -----
+;;; The following functions may be useful for viewing the database and
+;;; debugging the calling patterns.
+;;;
+;;; *LAST-FORM* () [VARIABLE]
+;;; The last form read from the file. Useful for figuring out what went
+;;; wrong when xref-file drops into the debugger.
+;;;
+;;; *XREF-VERBOSE* t [VARIABLE]
+;;; When T, xref-file(s) prints out the names of the files it looks at,
+;;; progress dots, and the number of forms read.
+;;;
+;;; *TYPES-TO-IGNORE* (quote (:lisp :lisp2)) [VARIABLE]
+;;; Default set of caller types (as specified in the patterns) to ignore
+;;; in the database handling functions. :lisp is CLtL 1st edition,
+;;; :lisp2 is additional patterns from CLtL 2nd edition.
+;;;
+;;; *HANDLE-PACKAGE-FORMS* () [VARIABLE]
+;;; When non-NIL, and XREF-FILE sees a package-setting form like
+;;; IN-PACKAGE, sets the current package to the specified package by
+;;; evaluating the form. When done with the file, xref-file resets the
+;;; package to its original value. In some of the displaying functions,
+;;; when this variable is non-NIL one may specify that all symbols from a
+;;; particular set of packages be ignored. This is only useful if the
+;;; files use different packages with conflicting names.
+;;;
+;;; *HANDLE-FUNCTION-FORMS* t [VARIABLE]
+;;; When T, XREF-FILE tries to be smart about forms which occur in
+;;; a function position, such as lambdas and arbitrary Lisp forms.
+;;; If so, it recursively calls record-callers with pattern 'FORM.
+;;; If the form is a lambda, makes the caller a caller of
+;;; :unnamed-lambda.
+;;;
+;;; *HANDLE-MACRO-FORMS* t [VARIABLE]
+;;; When T, if the file was loaded before being processed by XREF, and
+;;; the car of a form is a macro, it notes that the parent calls the
+;;; macro, and then calls macroexpand-1 on the form.
+;;;
+;;; *DEFAULT-GRAPHING-MODE* :call-graph [VARIABLE]
+;;; Specifies whether we graph up or down. If :call-graph, the children
+;;; of a node are the functions it calls. If :caller-graph, the
+;;; children of a node are the functions that call it.
+;;;
+;;; *INDENT-AMOUNT* 3 [VARIABLE]
+;;; Number of spaces to indent successive levels in PRINT-INDENTED-TREE.
+;;;
+;;; DISPLAY-DATABASE (&optional database types-to-ignore) [FUNCTION]
+;;; Prints out the name of each symbol and all its callers. Specify
+;;; database :callers (the default) to get function call references,
+;;; :file to the get files in which the symbol is called, :readers to get
+;;; variable references, and :setters to get variable binding and
+;;; assignments. Ignores functions of types listed in types-to-ignore.
+;;;
+;;; PRINT-CALLER-TREES (&key (mode *default-graphing-mode*) [FUNCTION]
+;;; (types-to-ignore *types-to-ignore*)
+;;; compact root-nodes)
+;;; Prints the calling trees (which may actually be a full graph and not
+;;; necessarily a DAG) as indented text trees using
+;;; PRINT-INDENTED-TREE. MODE is :call-graph for trees where the children
+;;; of a node are the functions called by the node, or :caller-graph for
+;;; trees where the children of a node are the functions the node calls.
+;;; TYPES-TO-IGNORE is a list of funcall types (as specified in the
+;;; patterns) to ignore in printing out the database. For example,
+;;; '(:lisp) would ignore all calls to common lisp functions. COMPACT is
+;;; a flag to tell the program to try to compact the trees a bit by not
+;;; printing trees if they have already been seen. ROOT-NODES is a list
+;;; of root nodes of trees to display. If ROOT-NODES is nil, tries to
+;;; find all root nodes in the database.
+;;;
+;;; MAKE-CALLER-TREE (&optional (mode *default-graphing-mode*) [FUNCTION]
+;;; (types-to-ignore *types-to-ignore*)
+;;; compact)
+;;; Outputs list structure of a tree which roughly represents the
+;;; possibly cyclical structure of the caller database.
+;;; If mode is :call-graph, the children of a node are the functions
+;;; it calls. If mode is :caller-graph, the children of a node are the
+;;; functions that call it.
+;;; If compact is T, tries to eliminate the already-seen nodes, so
+;;; that the graph for a node is printed at most once. Otherwise it will
+;;; duplicate the node's tree (except for cycles). This is usefull
+;;; because the call tree is actually a directed graph, so we can either
+;;; duplicate references or display only the first one.
+;;;
+;;; DETERMINE-FILE-DEPENDENCIES (&optional database) [FUNCTION]
+;;; Makes a hash table of file dependencies for the references listed in
+;;; DATABASE. This function may be useful for automatically resolving
+;;; file references for automatic creation of a system definition
+;;; (defsystem).
+;;;
+;;; PRINT-FILE-DEPENDENCIES (&optional database) [FUNCTION]
+;;; Prints a list of file dependencies for the references listed in
+;;; DATABASE. This function may be useful for automatically computing
+;;; file loading constraints for a system definition tool.
+;;;
+;;; WRITE-CALLERS-DATABASE-TO-FILE (filename) [FUNCTION]
+;;; Saves the contents of the current callers database to a file. This
+;;; file can be loaded to restore the previous contents of the
+;;; database. (For large systems it can take a long time to crunch
+;;; through the code, so this can save some time.)
+;;;
+;;; -----
+;;; The following macros define new function and macro call patterns.
+;;; They may be used to extend the static analysis tool to handle
+;;; new def forms, extensions to Common Lisp, and program defs.
+;;;
+;;; DEFINE-PATTERN-SUBSTITUTION (name pattern) [MACRO]
+;;; Defines NAME to be equivalent to the specified pattern. Useful for
+;;; making patterns more readable. For example, the LAMBDA-LIST is
+;;; defined as a pattern substitution, making the definition of the
+;;; DEFUN caller-pattern simpler.
+;;;
+;;; DEFINE-CALLER-PATTERN (name pattern &optional caller-type) [MACRO]
+;;; Defines NAME as a function/macro call with argument structure
+;;; described by PATTERN. CALLER-TYPE, if specified, assigns a type to
+;;; the pattern, which may be used to exclude references to NAME while
+;;; viewing the database. For example, all the Common Lisp definitions
+;;; have a caller-type of :lisp or :lisp2, so that you can exclude
+;;; references to common lisp functions from the calling tree.
+;;;
+;;; DEFINE-VARIABLE-PATTERN (name &optional caller-type) [MACRO]
+;;; Defines NAME as a variable reference of type CALLER-TYPE. This is
+;;; mainly used to establish the caller-type of the variable.
+;;;
+;;; DEFINE-CALLER-PATTERN-SYNONYMS (source destinations) [MACRO]
+;;; For defining function caller pattern syntax synonyms. For each name
+;;; in DESTINATIONS, defines its pattern as a copy of the definition
+;;; of SOURCE. Allows a large number of identical patterns to be defined
+;;; simultaneously. Must occur after the SOURCE has been defined.
+;;;
+;;; -----
+;;; This system includes pattern definitions for the latest
+;;; common lisp specification, as published in Guy Steele,
+;;; Common Lisp: The Language, 2nd Edition.
+;;;
+;;; Patterns may be either structures to match, or a predicate
+;;; like symbolp/numberp/stringp. The pattern specification language
+;;; is similar to the notation used in CLtL2, but in a more lisp-like
+;;; form:
+;;; (:eq name) The form element must be eq to the symbol NAME.
+;;; (:test test) TEST must be true when applied to the form element.
+;;; (:typep type) The form element must be of type TYPE.
+;;; (:or pat1 pat2 ...) Tries each of the patterns in left-to-right order,
+;;; until one succeeds.
+;;; Equivalent to { pat1 | pat2 | ... }
+;;; (:rest pattern) The remaining form elements are grouped into a
+;;; list which is matched against PATTERN.
+;;; (:optional pat1 ...) The patterns may optionally match against the
+;;; form element.
+;;; Equivalent to [ pat1 ... ].
+;;; (:star pat1 ...) The patterns may match against the patterns
+;;; any number of times, including 0.
+;;; Equivalent to { pat1 ... }*.
+;;; (:plus pat1 ...) The patterns may match against the patterns
+;;; any number of times, but at least once.
+;;; Equivalent to { pat1 ... }+.
+;;; &optional, &key, Similar in behavior to the corresponding
+;;; &rest lambda-list keywords.
+;;; FORM A random lisp form. If a cons, assumes the
+;;; car is a function or macro and tries to
+;;; match the args against that symbol's pattern.
+;;; If a symbol, assumes it's a variable reference.
+;;; :ignore Ignores the corresponding form element.
+;;; NAME The corresponding form element should be
+;;; the name of a new definition (e.g., the
+;;; first arg in a defun pattern is NAME.
+;;; FUNCTION, MACRO The corresponding form element should be
+;;; a function reference not handled by FORM.
+;;; Used in the definition of apply and funcall.
+;;; VAR The corresponding form element should be
+;;; a variable definition or mutation. Used
+;;; in the definition of let, let*, etc.
+;;; VARIABLE The corresponding form element should be
+;;; a variable reference.
+;;;
+;;; In all other pattern symbols, it looks up the symbols pattern substitution
+;;; and recursively matches against the pattern. Automatically destructures
+;;; list structure that does not include consing dots.
+;;;
+;;; Among the pattern substitution names defined are:
+;;; STRING, SYMBOL, NUMBER Appropriate :test patterns.
+;;; LAMBDA-LIST Matches against a lambda list.
+;;; BODY Matches against a function body definition.
+;;; FN Matches against #'function, 'function,
+;;; and lambdas. This is used in the definition
+;;; of apply, funcall, and the mapping patterns.
+;;; and others...
+;;;
+;;; Here's some sample pattern definitions:
+;;; (define-caller-pattern defun
+;;; (name lambda-list
+;;; (:star (:or documentation-string declaration))
+;;; (:star form))
+;;; :lisp)
+;;; (define-caller-pattern funcall (fn (:star form)) :lisp)
+;;;
+;;; In general, the system is intelligent enough to handle any sort of
+;;; simple funcall. One only need specify the syntax for functions and
+;;; macros which use optional arguments, keyword arguments, or some
+;;; argument positions are special, such as in apply and funcall, or
+;;; to indicate that the function is of the specified caller type.
+;;;
+;;;
+;;; NOTES:
+;;;
+;;; XRef assumes syntactically correct lisp code.
+;;;
+;;; This is by no means perfect. For example, let and let* are treated
+;;; identically, instead of differentiating between serial and parallel
+;;; binding. But it's still a useful tool. It can be helpful in
+;;; maintaining code, debugging problems with patch files, determining
+;;; whether functions are multiply defined, and help you remember where
+;;; a function is defined or called.
+;;;
+;;; XREF runs best when compiled.
+
+;;; ********************************
+;;; References *********************
+;;; ********************************
+;;;
+;;; Xerox Interlisp Masterscope Program:
+;;; Larry M Masinter, Global program analysis in an interactive environment
+;;; PhD Thesis, Stanford University, 1980.
+;;;
+;;; Symbolics Who-Calls Database:
+;;; User's Guide to Symbolics Computers, Volume 1, Cambridge, MA, July 1986
+;;; Genera 7.0, pp 183-185.
+;;;
+
+;;; ********************************
+;;; Example ************************
+;;; ********************************
+;;;
+;;; Here is an example of running XREF on a short program.
+;;; [In Scribe documentation, give a simple short program and resulting
+;;; XREF output, including postscript call graphs.]
+#|
+<cl> (xref:xref-file "/afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp")
+Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp.
+................................................
+48 forms processed.
+<cl> (xref:display-database :readers)
+
+*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION
+CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
+*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION
+CALCULATE-LEVEL-POSITION-BEFORE.
+*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO.
+*DIRECTION* is referenced by CREATE-POSITION-INFO.
+*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT.
+*ROOT-IS-SEQUENCE* is referenced by GRAPH.
+*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION
+CALCULATE-LEVEL-POSITION-BEFORE.
+*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION
+CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
+*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO.
+*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE.
+*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION
+CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE.
+*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE.
+<cl> (xref:print-caller-trees :root-nodes '(display-graph))
+
+Rooted calling trees:
+ DISPLAY-GRAPH
+ CREATE-POSITION-INFO
+ CALCULATE-POSITION-INFO
+ CALCULATE-POSITION
+ NODE-POSITION-ALREADY-SET-FLAG
+ NODE-LEVEL-ALREADY-SET-FLAG
+ CALCULATE-POSITION-IN-LEVEL
+ NODE-CHILDREN
+ NODE-LEVEL
+ CALCULATE-POSITION
+ NEW-CALCULATE-BREADTH
+ NODE-CHILDREN
+ BREADTH
+ OPPOSITE-DIMENSION
+ NODE-HEIGHT
+ NODE-WIDTH
+ NEW-CALCULATE-BREADTH
+ NODE-PARENTS
+ OPPOSITE-DIMENSION
+ NODE-HEIGHT
+ NODE-WIDTH
+ OPPOSITE-POSITION
+ NODE-Y
+ NODE-X
+ NODE-LEVEL
+ CALCULATE-LEVEL-POSITION
+ NODE-LEVEL
+ NODE-POSITION
+ NODE-X
+ NODE-Y
+ DIMENSION
+ NODE-WIDTH
+ NODE-HEIGHT
+ CALCULATE-LEVEL-POSITION-BEFORE
+ NODE-LEVEL
+ NODE-POSITION
+ NODE-X
+ NODE-Y
+ NODE-WIDTH
+ NODE-HEIGHT
+ DIMENSION
+ NODE-WIDTH
+ NODE-HEIGHT
+|#
+
+;;; ****************************************************************
+;;; List Callers ***************************************************
+;;; ****************************************************************
+
+(defpackage :pxref
+ (:use :common-lisp)
+ (:export #:list-callers
+ #:list-users
+ #:list-readers
+ #:list-setters
+ #:what-files-call
+ #:who-calls
+ #:list-callees
+ #:source-file
+ #:clear-tables
+ #:define-pattern-substitution
+ #:define-caller-pattern
+ #:define-variable-pattern
+ #:define-caller-pattern-synonyms
+ #:clear-patterns
+ #:*last-form*
+ #:*xref-verbose*
+ #:*handle-package-forms*
+ #:*handle-function-forms*
+ #:*handle-macro-forms*
+ #:*types-to-ignore*
+ #:*last-caller-tree*
+ #:*default-graphing-mode*
+ #:*indent-amount*
+ #:xref-file
+ #:xref-files
+ #:write-callers-database-to-file
+ #:display-database
+ #:print-caller-trees
+ #:make-caller-tree
+ #:print-indented-tree
+ #:determine-file-dependencies
+ #:print-file-dependencies
+ #:psgraph-xref
+ ))
+
+(in-package "PXREF")
+
+;;; Warn user if they're loading the source instead of compiling it first.
+;(eval-when (compile load eval)
+; (defvar compiled-p nil))
+;(eval-when (compile load)
+; (setq compiled-p t))
+;(eval-when (load eval)
+; (unless compiled-p
+; (warn "This file should be compiled before loading for best results.")))
+(eval-when (eval)
+ (warn "This file should be compiled before loading for best results."))
+
+
+;;; ********************************
+;;; Primitives *********************
+;;; ********************************
+(defun lookup (symbol environment)
+ (dolist (frame environment)
+ (when (member symbol frame)
+ (return symbol))))
+
+(defun car-eq (list item)
+ (and (consp list)
+ (eq (car list) item)))
+
+;;; ********************************
+;;; Callers Database ***************
+;;; ********************************
+(defvar *file-callers-database* (make-hash-table :test #'equal)
+ "Contains name and list of file callers (files which call) for that name.")
+(defvar *callers-database* (make-hash-table :test #'equal)
+ "Contains name and list of callers (function invocation) for that name.")
+(defvar *readers-database* (make-hash-table :test #'equal)
+ "Contains name and list of readers (variable use) for that name.")
+(defvar *setters-database* (make-hash-table :test #'equal)
+ "Contains name and list of setters (variable mutation) for that name.")
+(defvar *callees-database* (make-hash-table :test #'equal)
+ "Contains name and list of functions and variables it calls.")
+(defun callers-list (name &optional (database :callers))
+ (case database
+ (:file (gethash name *file-callers-database*))
+ (:callees (gethash name *callees-database*))
+ (:callers (gethash name *callers-database*))
+ (:readers (gethash name *readers-database*))
+ (:setters (gethash name *setters-database*))))
+(defsetf callers-list (name &optional (database :callers)) (caller)
+ `(setf (gethash ,name (case ,database
+ (:file *file-callers-database*)
+ (:callees *callees-database*)
+ (:callers *callers-database*)
+ (:readers *readers-database*)
+ (:setters *setters-database*)))
+ ,caller))
+
+(defun list-callers (symbol)
+ "Lists all functions which call SYMBOL as a function (function invocation)."
+ (callers-list symbol :callers))
+(defun list-readers (symbol)
+ "Lists all functions which refer to SYMBOL as a variable
+ (variable reference)."
+ (callers-list symbol :readers))
+(defun list-setters (symbol)
+ "Lists all functions which bind/set SYMBOL as a variable
+ (variable mutation)."
+ (callers-list symbol :setters))
+(defun list-users (symbol)
+ "Lists all functions which use SYMBOL as a variable or function."
+ (values (list-callers symbol)
+ (list-readers symbol)
+ (list-setters symbol)))
+(defun who-calls (symbol &optional how)
+ "Lists callers of symbol. HOW may be :function, :reader, :setter,
+ or :variable."
+ ;; would be nice to have :macro and distinguish variable
+ ;; binding from assignment. (i.e., variable binding, assignment, and use)
+ (case how
+ (:function (list-callers symbol))
+ (:reader (list-readers symbol))
+ (:setter (list-setters symbol))
+ (:variable (append (list-readers symbol)
+ (list-setters symbol)))
+ (otherwise (append (list-callers symbol)
+ (list-readers symbol)
+ (list-setters symbol)))))
+(defun what-files-call (symbol)
+ "Lists names of files that contain uses of SYMBOL
+ as a function, variable, or constant."
+ (callers-list symbol :file))
+(defun list-callees (symbol)
+ "Lists names of functions and variables called by SYMBOL."
+ (callers-list symbol :callees))
+
+(defvar *source-file* (make-hash-table :test #'equal)
+ "Contains function name and source file for that name.")
+(defun source-file (symbol)
+ "Lists the names of files in which SYMBOL is defined/used."
+ (gethash symbol *source-file*))
+(defsetf source-file (name) (value)
+ `(setf (gethash ,name *source-file*) ,value))
+
+(defun clear-tables ()
+ (clrhash *file-callers-database*)
+ (clrhash *callers-database*)
+ (clrhash *callees-database*)
+ (clrhash *readers-database*)
+ (clrhash *setters-database*)
+ (clrhash *source-file*))
+
+
+;;; ********************************
+;;; Pattern Database ***************
+;;; ********************************
+;;; Pattern Types
+(defvar *pattern-caller-type* (make-hash-table :test #'equal))
+(defun pattern-caller-type (name)
+ (gethash name *pattern-caller-type*))
+(defsetf pattern-caller-type (name) (value)
+ `(setf (gethash ,name *pattern-caller-type*) ,value))
+
+;;; Pattern Substitutions
+(defvar *pattern-substitution-table* (make-hash-table :test #'equal)
+ "Stores general patterns for function destructuring.")
+(defun lookup-pattern-substitution (name)
+ (gethash name *pattern-substitution-table*))
+(defmacro define-pattern-substitution (name pattern)
+ "Defines NAME to be equivalent to the specified pattern. Useful for
+ making patterns more readable. For example, the LAMBDA-LIST is
+ defined as a pattern substitution, making the definition of the
+ DEFUN caller-pattern simpler."
+ `(setf (gethash ',name *pattern-substitution-table*)
+ ',pattern))
+
+;;; Function/Macro caller patterns:
+;;; The car of the form is skipped, so we don't need to specify
+;;; (:eq function-name) like we would for a substitution.
+;;;
+;;; Patterns must be defined in the XREF package because the pattern
+;;; language is tested by comparing symbols (using #'equal) and not
+;;; their printreps. This is fine for the lisp grammer, because the XREF
+;;; package depends on the LISP package, so a symbol like 'xref::cons is
+;;; translated automatically into 'lisp::cons. However, since
+;;; (equal 'foo::bar 'baz::bar) returns nil unless both 'foo::bar and
+;;; 'baz::bar are inherited from the same package (e.g., LISP),
+;;; if package handling is turned on the user must specify package
+;;; names in the caller pattern definitions for functions that occur
+;;; in packages other than LISP, otherwise the symbols will not match.
+;;;
+;;; Perhaps we should enforce the definition of caller patterns in the
+;;; XREF package by wrapping the body of define-caller-pattern in
+;;; the XREF package:
+;;; (defmacro define-caller-pattern (name value &optional caller-type)
+;;; (let ((old-package *package*))
+;;; (setf *package* (find-package "XREF"))
+;;; (prog1
+;;; `(progn
+;;; (when ',caller-type
+;;; (setf (pattern-caller-type ',name) ',caller-type))
+;;; (when ',value
+;;; (setf (gethash ',name *caller-pattern-table*)
+;;; ',value)))
+;;; (setf *package* old-package))))
+;;; Either that, or for the purpose of pattern testing we should compare
+;;; printreps. [The latter makes the primitive patterns like VAR
+;;; reserved words.]
+(defvar *caller-pattern-table* (make-hash-table :test #'equal)
+ "Stores patterns for function destructuring.")
+(defun lookup-caller-pattern (name)
+ (gethash name *caller-pattern-table*))
+(defmacro define-caller-pattern (name pattern &optional caller-type)
+ "Defines NAME as a function/macro call with argument structure
+ described by PATTERN. CALLER-TYPE, if specified, assigns a type to
+ the pattern, which may be used to exclude references to NAME while
+ viewing the database. For example, all the Common Lisp definitions
+ have a caller-type of :lisp or :lisp2, so that you can exclude
+ references to common lisp functions from the calling tree."
+ `(progn
+ (when ',caller-type
+ (setf (pattern-caller-type ',name) ',caller-type))
+ (when ',pattern
+ (setf (gethash ',name *caller-pattern-table*)
+ ',pattern))))
+
+;;; For defining variables
+(defmacro define-variable-pattern (name &optional caller-type)
+ "Defines NAME as a variable reference of type CALLER-TYPE. This is
+ mainly used to establish the caller-type of the variable."
+ `(progn
+ (when ',caller-type
+ (setf (pattern-caller-type ',name) ',caller-type))))
+
+;;; For defining synonyms. Means much less space taken up by the patterns.
+(defmacro define-caller-pattern-synonyms (source destinations)
+ "For defining function caller pattern syntax synonyms. For each name
+ in DESTINATIONS, defines its pattern as a copy of the definition of SOURCE.
+ Allows a large number of identical patterns to be defined simultaneously.
+ Must occur after the SOURCE has been defined."
+ `(let ((source-type (pattern-caller-type ',source))
+ (source-pattern (gethash ',source *caller-pattern-table*)))
+ (when source-type
+ (dolist (dest ',destinations)
+ (setf (pattern-caller-type dest) source-type)))
+ (when source-pattern
+ (dolist (dest ',destinations)
+ (setf (gethash dest *caller-pattern-table*)
+ source-pattern)))))
+
+(defun clear-patterns ()
+ (clrhash *pattern-substitution-table*)
+ (clrhash *caller-pattern-table*)
+ (clrhash *pattern-caller-type*))
+
+;;; ********************************
+;;; Cross Reference Files **********
+;;; ********************************
+(defvar *last-form* ()
+ "The last form read from the file. Useful for figuring out what went wrong
+ when xref-file drops into the debugger.")
+
+(defvar *xref-verbose* t
+ "When T, xref-file(s) prints out the names of the files it looks at,
+ progress dots, and the number of forms read.")
+
+;;; This needs to first clear the tables?
+(defun xref-files (&rest files)
+ "Grovels over the lisp code located in source file FILES, using xref-file."
+ ;; If the arg is a list, use it.
+ (when (listp (car files)) (setq files (car files)))
+ (dolist (file files)
+ (xref-file file nil))
+ (values))
+
+(defvar *handle-package-forms* nil ;'(lisp::in-package)
+ "When non-NIL, and XREF-FILE sees a package-setting form like IN-PACKAGE,
+ sets the current package to the specified package by evaluating the
+ form. When done with the file, xref-file resets the package to its
+ original value. In some of the displaying functions, when this variable
+ is non-NIL one may specify that all symbols from a particular set of
+ packages be ignored. This is only useful if the files use different
+ packages with conflicting names.")
+
+(defvar *normal-readtable* (copy-readtable nil)
+ "Normal, unadulterated CL readtable.")
+
+(defun xref-file (filename &optional (clear-tables t) (verbose *xref-verbose*))
+ "Cross references the function and variable calls in FILENAME by
+ walking over the source code located in the file. Defaults type of
+ filename to \".lisp\". Chomps on the code using record-callers and
+ record-callers*. If CLEAR-TABLES is T (the default), it clears the callers
+ database before processing the file. Specify CLEAR-TABLES as nil to
+ append to the database. If VERBOSE is T (the default), prints out the
+ name of the file, one progress dot for each form processed, and the
+ total number of forms."
+ ;; Default type to "lisp"
+ (when (and (null (pathname-type filename))
+ (not (probe-file filename)))
+ (cond ((stringp filename)
+ (setf filename (concatenate 'string filename ".lisp")))
+ ((pathnamep filename)
+ (setf filename (merge-pathnames filename
+ (make-pathname :type "lisp"))))))
+ (when clear-tables (clear-tables))
+ (let ((count 0)
+ (old-package *package*)
+ (*readtable* *normal-readtable*))
+ (when verbose
+ (format t "~&Cross-referencing file ~A.~&" filename))
+ (with-open-file (stream filename :direction :input)
+ (do ((form (read stream nil :eof) (read stream nil :eof)))
+ ((eq form :eof))
+ (incf count)
+ (when verbose
+ (format *standard-output* ".")
+ (force-output *standard-output*))
+ (setq *last-form* form)
+ (record-callers filename form)
+ ;; Package Magic.
+ (when (and *handle-package-forms*
+ (consp form)
+ (member (car form) *handle-package-forms*))
+ (eval form))))
+ (when verbose
+ (format t "~&~D forms processed." count))
+ (setq *package* old-package)
+ (values)))
+
+(defvar *handle-function-forms* t
+ "When T, XREF-FILE tries to be smart about forms which occur in
+ a function position, such as lambdas and arbitrary Lisp forms.
+ If so, it recursively calls record-callers with pattern 'FORM.
+ If the form is a lambda, makes the caller a caller of :unnamed-lambda.")
+
+(defvar *handle-macro-forms* t
+ "When T, if the file was loaded before being processed by XREF, and the
+ car of a form is a macro, it notes that the parent calls the macro,
+ and then calls macroexpand-1 on the form.")
+
+(defvar *callees-database-includes-variables* nil)
+
+(defun record-callers (filename form
+ &optional pattern parent (environment nil)
+ funcall)
+ "RECORD-CALLERS is the main routine used to walk down the code. It matches
+ the PATTERN against the FORM, possibly adding statements to the database.
+ PARENT is the name defined by the current outermost definition; it is
+ the caller of the forms in the body (e.g., FORM). ENVIRONMENT is used
+ to keep track of the scoping of variables. FUNCALL deals with the type
+ of variable assignment and hence how the environment should be modified.
+ RECORD-CALLERS handles atomic patterns and simple list-structure patterns.
+ For complex list-structure pattern destructuring, it calls RECORD-CALLERS*."
+; (when form)
+ (unless pattern (setq pattern 'FORM))
+ (cond ((symbolp pattern)
+ (case pattern
+ (:IGNORE
+ ;; Ignores the rest of the form.
+ (values t parent environment))
+ (NAME
+ ;; This is the name of a new definition.
+ (push filename (source-file form))
+ (values t form environment))
+ ((FUNCTION MACRO)
+ ;; This is the name of a call.
+ (cond ((and *handle-function-forms* (consp form))
+ ;; If we're a cons and special handling is on,
+ (when (eq (car form) 'lambda)
+ (pushnew filename (callers-list :unnamed-lambda :file))
+ (when parent
+ (pushnew parent (callers-list :unnamed-lambda
+ :callers))
+ (pushnew :unnamed-lambda (callers-list parent
+ :callees))))
+ (record-callers filename form 'form parent environment))
+ (t
+ ;; If we're just a regular function name call.
+ (pushnew filename (callers-list form :file))
+ (when parent
+ (pushnew parent (callers-list form :callers))
+ (pushnew form (callers-list parent :callees)))
+ (values t parent environment))))
+ (VAR
+ ;; This is the name of a new variable definition.
+ ;; Includes arglist parameters.
+ (when (and (symbolp form) (not (keywordp form))
+ (not (member form lambda-list-keywords)))
+ (pushnew form (car environment))
+ (pushnew filename (callers-list form :file))
+ (when parent
+; (pushnew form (callers-list parent :callees))
+ (pushnew parent (callers-list form :setters)))
+ (values t parent environment)))
+ (VARIABLE
+ ;; VAR reference
+ (pushnew filename (callers-list form :file))
+ (when (and parent (not (lookup form environment)))
+ (pushnew parent (callers-list form :readers))
+ (when *callees-database-includes-variables*
+ (pushnew form (callers-list parent :callees))))
+ (values t parent environment))
+ (FORM
+ ;; A random form (var or funcall).
+ (cond ((consp form)
+ ;; Get new pattern from TAG.
+ (let ((new-pattern (lookup-caller-pattern (car form))))
+ (pushnew filename (callers-list (car form) :file))
+ (when parent
+ (pushnew parent (callers-list (car form) :callers))
+ (pushnew (car form) (callers-list parent :callees)))
+ (cond ((and new-pattern (cdr form))
+ ;; Special Pattern and there's stuff left
+ ;; to be processed. Note that we check if
+ ;; a pattern is defined for the form before
+ ;; we check to see if we can macroexpand it.
+ (record-callers filename (cdr form) new-pattern
+ parent environment :funcall))
+ ((and *handle-macro-forms*
+ (symbolp (car form)) ; pnorvig 9/9/93
+ (macro-function (car form)))
+ ;; The car of the form is a macro and
+ ;; macro processing is turned on. Macroexpand-1
+ ;; the form and try again.
+ (record-callers filename
+ (macroexpand-1 form)
+ 'form parent environment
+ :funcall))
+ ((null (cdr form))
+ ;; No more left to be processed. Note that
+ ;; this must occur after the macros clause,
+ ;; since macros can expand into more code.
+ (values t parent environment))
+ (t
+ ;; Random Form. We assume it is a function call.
+ (record-callers filename (cdr form)
+ '((:star FORM))
+ parent environment :funcall)))))
+ (t
+ (when (and (not (lookup form environment))
+ (not (numberp form))
+ ;; the following line should probably be
+ ;; commented out?
+ (not (keywordp form))
+ (not (stringp form))
+ (not (eq form t))
+ (not (eq form nil)))
+ (pushnew filename (callers-list form :file))
+ ;; ??? :callers
+ (when parent
+ (pushnew parent (callers-list form :readers))
+ (when *callees-database-includes-variables*
+ (pushnew form (callers-list parent :callees)))))
+ (values t parent environment))))
+ (otherwise
+ ;; Pattern Substitution
+ (let ((new-pattern (lookup-pattern-substitution pattern)))
+ (if new-pattern
+ (record-callers filename form new-pattern
+ parent environment)
+ (when (eq pattern form)
+ (values t parent environment)))))))
+ ((consp pattern)
+ (case (car pattern)
+ (:eq (when (eq (second pattern) form)
+ (values t parent environment)))
+ (:test (when (funcall (eval (second pattern)) form)
+ (values t parent environment)))
+ (:typep (when (typep form (second pattern))
+ (values t parent environment)))
+ (:or (dolist (subpat (rest pattern))
+ (multiple-value-bind (processed parent environment)
+ (record-callers filename form subpat
+ parent environment)
+ (when processed
+ (return (values processed parent environment))))))
+ (:rest ; (:star :plus :optional :rest)
+ (record-callers filename form (second pattern)
+ parent environment))
+ (otherwise
+ (multiple-value-bind (d p env)
+ (record-callers* filename form pattern
+ parent (cons nil environment))
+ (values d p (if funcall environment env))))))))
+
+(defun record-callers* (filename form pattern parent environment
+ &optional continuation
+ in-optionals in-keywords)
+ "RECORD-CALLERS* handles complex list-structure patterns, such as
+ ordered lists of subpatterns, patterns involving :star, :plus,
+ &optional, &key, &rest, and so on. CONTINUATION is a stack of
+ unprocessed patterns, IN-OPTIONALS and IN-KEYWORDS are corresponding
+ stacks which determine whether &rest or &key has been seen yet in
+ the current pattern."
+ ;; form must be a cons or nil.
+; (when form)
+ (if (null pattern)
+ (if (null continuation)
+ (values t parent environment)
+ (record-callers* filename form (car continuation) parent environment
+ (cdr continuation)
+ (cdr in-optionals)
+ (cdr in-keywords)))
+ (let ((pattern-elt (car pattern)))
+ (cond ((car-eq pattern-elt :optional)
+ (if (null form)
+ (values t parent environment)
+ (multiple-value-bind (processed par env)
+ (record-callers* filename form (cdr pattern-elt)
+ parent environment
+ (cons (cdr pattern) continuation)
+ (cons (car in-optionals) in-optionals)
+ (cons (car in-keywords) in-keywords))
+ (if processed
+ (values processed par env)
+ (record-callers* filename form (cdr pattern)
+ parent environment continuation
+ in-optionals in-keywords)))))
+ ((car-eq pattern-elt :star)
+ (if (null form)
+ (values t parent environment)
+ (multiple-value-bind (processed par env)
+ (record-callers* filename form (cdr pattern-elt)
+ parent environment
+ (cons pattern continuation)
+ (cons (car in-optionals) in-optionals)
+ (cons (car in-keywords) in-keywords))
+ (if processed
+ (values processed par env)
+ (record-callers* filename form (cdr pattern)
+ parent environment continuation
+ in-optionals in-keywords)))))
+ ((car-eq pattern-elt :plus)
+ (record-callers* filename form (cdr pattern-elt)
+ parent environment
+ (cons (cons (cons :star (cdr pattern-elt))
+ (cdr pattern))
+ continuation)
+ (cons (car in-optionals) in-optionals)
+ (cons (car in-keywords) in-keywords)))
+ ((car-eq pattern-elt :rest)
+ (record-callers filename form pattern-elt parent environment))
+ ((eq pattern-elt '&optional)
+ (record-callers* filename form (cdr pattern)
+ parent environment continuation
+ (cons t in-optionals)
+ (cons (car in-keywords) in-keywords)))
+ ((eq pattern-elt '&rest)
+ (record-callers filename form (second pattern)
+ parent environment))
+ ((eq pattern-elt '&key)
+ (record-callers* filename form (cdr pattern)
+ parent environment continuation
+ (cons (car in-optionals) in-optionals)
+ (cons t in-keywords)))
+ ((null form)
+ (when (or (car in-keywords) (car in-optionals))
+ (values t parent environment)))
+ ((consp form)
+ (multiple-value-bind (processed parent environment)
+ (record-callers filename (if (car in-keywords)
+ (cadr form)
+ (car form))
+ pattern-elt
+ parent environment)
+ (cond (processed
+ (record-callers* filename (if (car in-keywords)
+ (cddr form)
+ (cdr form))
+ (cdr pattern)
+ parent environment
+ continuation
+ in-optionals in-keywords))
+ ((or (car in-keywords)
+ (car in-optionals))
+ (values t parent environment)))))))))
+
+
+;;; ********************************
+;;; Misc Utilities *****************
+;;; ********************************
+(defvar *types-to-ignore*
+ '(:lisp ; CLtL 1st Edition
+ :lisp2 ; CLtL 2nd Edition additional patterns
+ )
+ "Default set of caller types (as specified in the patterns) to ignore
+ in the database handling functions. :lisp is CLtL 1st edition,
+ :lisp2 is additional patterns from CLtL 2nd edition.")
+
+(defun display-database (&optional (database :callers)
+ (types-to-ignore *types-to-ignore*))
+ "Prints out the name of each symbol and all its callers. Specify database
+ :callers (the default) to get function call references, :fill to the get
+ files in which the symbol is called, :readers to get variable references,
+ and :setters to get variable binding and assignments. Ignores functions
+ of types listed in types-to-ignore."
+ (maphash #'(lambda (name callers)
+ (unless (or (member (pattern-caller-type name)
+ types-to-ignore)
+ ;; When we're doing fancy package crap,
+ ;; allow us to ignore symbols based on their
+ ;; packages.
+ (when *handle-package-forms*
+ (member (symbol-package name)
+ types-to-ignore
+ :key #'find-package)))
+ (format t "~&~S is referenced by~{ ~S~}."
+ name callers)))
+ (ecase database
+ (:file *file-callers-database*)
+ (:callers *callers-database*)
+ (:readers *readers-database*)
+ (:setters *setters-database*))))
+
+(defun write-callers-database-to-file (filename)
+ "Saves the contents of the current callers database to a file. This
+ file can be loaded to restore the previous contents of the
+ database. (For large systems it can take a long time to crunch
+ through the code, so this can save some time.)"
+ (with-open-file (stream filename :direction :output)
+ (format stream "~&(clear-tables)")
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (source-file '~S) '~S)"
+ x y))
+ *source-file*)
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (callers-list '~S :file) '~S)"
+ x y))
+ *file-callers-database*)
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (callers-list '~S :callers) '~S)"
+ x y))
+ *callers-database*)
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (callers-list '~S :callees) '~S)"
+ x y))
+ *callees-database*)
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (callers-list '~S :readers) '~S)"
+ x y))
+ *readers-database*)
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (callers-list '~S :setters) '~S)"
+ x y))
+ *setters-database*)))
+
+
+;;; ********************************
+;;; Print Caller Trees *************
+;;; ********************************
+;;; The following function is useful for reversing a caller table into
+;;; a callee table. Possibly later we'll extend xref to create two
+;;; such database hash tables. Needs to include vars as well.
+(defun invert-hash-table (table &optional (types-to-ignore *types-to-ignore*))
+ "Makes a copy of the hash table in which (name value*) pairs
+ are inverted to (value name*) pairs."
+ (let ((target (make-hash-table :test #'equal)))
+ (maphash #'(lambda (key values)
+ (dolist (value values)
+ (unless (member (pattern-caller-type key)
+ types-to-ignore)
+ (pushnew key (gethash value target)))))
+ table)
+ target))
+
+;;; Resolve file references for automatic creation of a defsystem file.
+(defun determine-file-dependencies (&optional (database *callers-database*))
+ "Makes a hash table of file dependencies for the references listed in
+ DATABASE. This function may be useful for automatically resolving
+ file references for automatic creation of a system definition (defsystem)."
+ (let ((file-ref-ht (make-hash-table :test #'equal)))
+ (maphash #'(lambda (key values)
+ (let ((key-file (source-file key)))
+ (when key
+ (dolist (value values)
+ (let ((value-file (source-file value)))
+ (when value-file
+ (dolist (s key-file)
+ (dolist (d value-file)
+ (pushnew d (gethash s file-ref-ht))))))))))
+ database)
+ file-ref-ht))
+
+(defun print-file-dependencies (&optional (database *callers-database*))
+ "Prints a list of file dependencies for the references listed in DATABASE.
+ This function may be useful for automatically computing file loading
+ constraints for a system definition tool."
+ (maphash #'(lambda (key value) (format t "~&~S --> ~S" key value))
+ (determine-file-dependencies database)))
+
+;;; The following functions demonstrate a possible way to interface
+;;; xref to a graphical browser such as psgraph to mimic the capabilities
+;;; of Masterscope's graphical browser.
+
+(defvar *last-caller-tree* nil)
+
+(defvar *default-graphing-mode* :call-graph
+ "Specifies whether we graph up or down. If :call-graph, the children
+ of a node are the functions it calls. If :caller-graph, the children
+ of a node are the functions that call it.")
+
+(defun gather-tree (parents &optional already-seen
+ (mode *default-graphing-mode*)
+ (types-to-ignore *types-to-ignore*) compact)
+ "Extends the tree, copying it into list structure, until it repeats
+ a reference (hits a cycle)."
+ (let ((*already-seen* nil)
+ (database (case mode
+ (:call-graph *callees-database*)
+ (:caller-graph *callers-database*))))
+ (declare (special *already-seen*))
+ (labels
+ ((amass-tree
+ (parents &optional already-seen)
+ (let (result this-item)
+ (dolist (parent parents)
+ (unless (member (pattern-caller-type parent)
+ types-to-ignore)
+ (pushnew parent *already-seen*)
+ (if (member parent already-seen)
+ (setq this-item nil) ; :ignore
+ (if compact
+ (multiple-value-setq (this-item already-seen)
+ (amass-tree (gethash parent database)
+ (cons parent already-seen)))
+ (setq this-item
+ (amass-tree (gethash parent database)
+ (cons parent already-seen)))))
+ (setq parent (format nil "~S" parent))
+ (when (consp parent) (setq parent (cons :xref-list parent)))
+ (unless (eq this-item :ignore)
+ (push (if this-item
+ (list parent this-item)
+ parent)
+ result))))
+ (values result ;(reverse result)
+ already-seen))))
+ (values (amass-tree parents already-seen)
+ *already-seen*))))
+
+(defun find-roots-and-cycles (&optional (mode *default-graphing-mode*)
+ (types-to-ignore *types-to-ignore*))
+ "Returns a list of uncalled callers (roots) and called callers (potential
+ cycles)."
+ (let ((uncalled-callers nil)
+ (called-callers nil)
+ (database (ecase mode
+ (:call-graph *callers-database*)
+ (:caller-graph *callees-database*)))
+ (other-database (ecase mode
+ (:call-graph *callees-database*)
+ (:caller-graph *callers-database*))))
+ (maphash #'(lambda (name value)
+ (declare (ignore value))
+ (unless (member (pattern-caller-type name)
+ types-to-ignore)
+ (if (gethash name database)
+ (push name called-callers)
+ (push name uncalled-callers))))
+ other-database)
+ (values uncalled-callers called-callers)))
+
+(defun make-caller-tree (&optional (mode *default-graphing-mode*)
+ (types-to-ignore *types-to-ignore*) compact)
+ "Outputs list structure of a tree which roughly represents the possibly
+ cyclical structure of the caller database.
+ If mode is :call-graph, the children of a node are the functions it calls.
+ If mode is :caller-graph, the children of a node are the functions that
+ call it.
+ If compact is T, tries to eliminate the already-seen nodes, so that
+ the graph for a node is printed at most once. Otherwise it will duplicate
+ the node's tree (except for cycles). This is usefull because the call tree
+ is actually a directed graph, so we can either duplicate references or
+ display only the first one."
+ ;; Would be nice to print out line numbers and whenever we skip a duplicated
+ ;; reference, print the line number of the full reference after the node.
+ (multiple-value-bind (uncalled-callers called-callers)
+ (find-roots-and-cycles mode types-to-ignore)
+ (multiple-value-bind (trees already-seen)
+ (gather-tree uncalled-callers nil mode types-to-ignore compact)
+ (setq *last-caller-tree* trees)
+ (let ((more-trees (gather-tree (set-difference called-callers
+ already-seen)
+ already-seen
+ mode types-to-ignore compact)))
+ (values trees more-trees)))))
+
+(defvar *indent-amount* 3
+ "Number of spaces to indent successive levels in PRINT-INDENTED-TREE.")
+
+(defun print-indented-tree (trees &optional (indent 0))
+ "Simple code to print out a list-structure tree (such as those created
+ by make-caller-tree) as indented text."
+ (when trees
+ (dolist (tree trees)
+ (cond ((and (listp tree) (eq (car tree) :xref-list))
+ (format t "~&~VT~A" indent (cdr tree)))
+ ((listp tree)
+ (format t "~&~VT~A" indent (car tree))
+ (print-indented-tree (cadr tree) (+ indent *indent-amount*)))
+ (t
+ (format t "~&~VT~A" indent tree))))))
+
+(defun print-caller-trees (&key (mode *default-graphing-mode*)
+ (types-to-ignore *types-to-ignore*)
+ compact
+ root-nodes)
+ "Prints the calling trees (which may actually be a full graph and not
+ necessarily a DAG) as indented text trees using PRINT-INDENTED-TREE.
+ MODE is :call-graph for trees where the children of a node are the
+ functions called by the node, or :caller-graph for trees where the
+ children of a node are the functions the node calls. TYPES-TO-IGNORE
+ is a list of funcall types (as specified in the patterns) to ignore
+ in printing out the database. For example, '(:lisp) would ignore all
+ calls to common lisp functions. COMPACT is a flag to tell the program
+ to try to compact the trees a bit by not printing trees if they have
+ already been seen. ROOT-NODES is a list of root nodes of trees to
+ display. If ROOT-NODES is nil, tries to find all root nodes in the
+ database."
+ (multiple-value-bind (rooted cycles)
+ (if root-nodes
+ (values (gather-tree root-nodes nil mode types-to-ignore compact))
+ (make-caller-tree mode types-to-ignore compact))
+ (when rooted
+ (format t "~&Rooted calling trees:")
+ (print-indented-tree rooted 2))
+ (when cycles
+ (when rooted
+ (format t "~2%"))
+ (format t "~&Cyclic calling trees:")
+ (print-indented-tree cycles 2))))
+
+
+;;; ********************************
+;;; Interface to PSGraph ***********
+;;; ********************************
+#|
+;;; Interface to Bates' PostScript Graphing Utility
+(load "/afs/cs/user/mkant/Lisp/PSGraph/psgraph")
+
+(defparameter *postscript-output-directory* "")
+(defun psgraph-xref (&key (mode *default-graphing-mode*)
+ (output-directory *postscript-output-directory*)
+ (types-to-ignore *types-to-ignore*)
+ (compact t)
+ (shrink t)
+ root-nodes
+ insert)
+ ;; If root-nodes is a non-nil list, uses that list as the starting
+ ;; position. Otherwise tries to find all roots in the database.
+ (multiple-value-bind (rooted cycles)
+ (if root-nodes
+ (values (gather-tree root-nodes nil mode types-to-ignore compact))
+ (make-caller-tree mode types-to-ignore compact))
+ (psgraph-output (append rooted cycles) output-directory shrink insert)))
+
+(defun psgraph-output (list-of-trees directory shrink &optional insert)
+ (let ((psgraph:*fontsize* 9)
+ (psgraph:*second-fontsize* 7)
+; (psgraph:*boxkind* "fill")
+ (psgraph:*boxgray* "0") ; .8
+ (psgraph:*edgewidth* "1")
+ (psgraph:*edgegray* "0"))
+ (labels ((stringify (thing)
+ (cond ((stringp thing) (string-downcase thing))
+ ((symbolp thing) (string-downcase (symbol-name thing)))
+ ((and (listp thing) (eq (car thing) :xref-list))
+ (stringify (cdr thing)))
+ ((listp thing) (stringify (car thing)))
+ (t (string thing)))))
+ (dolist (item list-of-trees)
+ (let* ((fname (stringify item))
+ (filename (concatenate 'string directory
+ (string-trim '(#\: #\|) fname)
+ ".ps")))
+ (format t "~&Creating PostScript file ~S." filename)
+ (with-open-file (*standard-output* filename
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ ;; Note that the #'eq prints the DAG as a tree. If
+ ;; you replace it with #'equal, it will print it as
+ ;; a DAG, which I think is slightly ugly.
+ (psgraph:psgraph item
+ #'caller-tree-children #'caller-info shrink
+ insert #'eq)))))))
+
+(defun caller-tree-children (tree)
+ (when (and tree (listp tree) (not (eq (car tree) :xref-list)))
+ (cadr tree)))
+
+(defun caller-tree-node (tree)
+ (when tree
+ (cond ((and (listp tree) (eq (car tree) :xref-list))
+ (cdr tree))
+ ((listp tree)
+ (car tree))
+ (t
+ tree))))
+
+(defun caller-info (tree)
+ (let ((node (caller-tree-node tree)))
+ (list node)))
+|#
+#|
+;;; Code to print out graphical trees of CLOS class hierarchies.
+(defun print-class-hierarchy (&optional (start-class 'anything)
+ (file "classes.ps"))
+ (let ((start (find-class start-class)))
+ (when start
+ (with-open-file (*standard-output* file :direction :output)
+ (psgraph:psgraph start
+ #'clos::class-direct-subclasses
+ #'(lambda (x)
+ (list (format nil "~A" (clos::class-name x))))
+ t nil #'eq)))))
+
+|#
+
+
+;;; ****************************************************************
+;;; Cross Referencing Patterns for Common Lisp *********************
+;;; ****************************************************************
+(clear-patterns)
+
+;;; ********************************
+;;; Pattern Substitutions **********
+;;; ********************************
+(define-pattern-substitution integer (:test #'integerp))
+(define-pattern-substitution rational (:test #'rationalp))
+(define-pattern-substitution symbol (:test #'symbolp))
+(define-pattern-substitution string (:test #'stringp))
+(define-pattern-substitution number (:test #'numberp))
+(define-pattern-substitution lambda-list
+ ((:star var)
+ (:optional (:eq &optional)
+ (:star (:or var
+ (var (:optional form (:optional var))))))
+ (:optional (:eq &rest) var)
+ (:optional (:eq &key) (:star (:or var
+ ((:or var
+ (keyword var))
+ (:optional form (:optional var)))))
+ (:optional &allow-other-keys))
+ (:optional (:eq &aux)
+ (:star (:or var
+ (var (:optional form)))))))
+(define-pattern-substitution test form)
+(define-pattern-substitution body
+ ((:star (:or declaration documentation-string))
+ (:star form)))
+(define-pattern-substitution documentation-string string)
+(define-pattern-substitution initial-value form)
+(define-pattern-substitution tag symbol)
+(define-pattern-substitution declaration ((:eq declare)(:rest :ignore)))
+(define-pattern-substitution destination form)
+(define-pattern-substitution control-string string)
+(define-pattern-substitution format-arguments
+ ((:star form)))
+(define-pattern-substitution fn
+ (:or ((:eq quote) function)
+ ((:eq function) function)
+ function))
+
+;;; ********************************
+;;; Caller Patterns ****************
+;;; ********************************
+
+;;; Types Related
+(define-caller-pattern coerce (form :ignore) :lisp)
+(define-caller-pattern type-of (form) :lisp)
+(define-caller-pattern upgraded-array-element-type (:ignore) :lisp2)
+(define-caller-pattern upgraded-complex-part-type (:ignore) :lisp2)
+
+;;; Lambdas and Definitions
+(define-variable-pattern lambda-list-keywords :lisp)
+(define-variable-pattern lambda-parameters-limit :lisp)
+(define-caller-pattern lambda (lambda-list (:rest body)) :lisp)
+
+(define-caller-pattern defun
+ (name lambda-list
+ (:star (:or documentation-string declaration))
+ (:star form))
+ :lisp)
+
+;;; perhaps this should use VAR, instead of NAME
+(define-caller-pattern defvar
+ (var (:optional initial-value (:optional documentation-string)))
+ :lisp)
+(define-caller-pattern defparameter
+ (var initial-value (:optional documentation-string))
+ :lisp)
+(define-caller-pattern defconstant
+ (var initial-value (:optional documentation-string))
+ :lisp)
+
+(define-caller-pattern eval-when
+ (:ignore ; the situations
+ (:star form))
+ :lisp)
+
+;;; Logical Values
+(define-variable-pattern nil :lisp)
+(define-variable-pattern t :lisp)
+
+;;; Predicates
+(define-caller-pattern typep (form form) :lisp)
+(define-caller-pattern subtypep (form form) :lisp)
+
+(define-caller-pattern null (form) :lisp)
+(define-caller-pattern symbolp (form) :lisp)
+(define-caller-pattern atom (form) :lisp)
+(define-caller-pattern consp (form) :lisp)
+(define-caller-pattern listp (form) :lisp)
+(define-caller-pattern numberp (form) :lisp)
+(define-caller-pattern integerp (form) :lisp)
+(define-caller-pattern rationalp (form) :lisp)
+(define-caller-pattern floatp (form) :lisp)
+(define-caller-pattern realp (form) :lisp2)
+(define-caller-pattern complexp (form) :lisp)
+(define-caller-pattern characterp (form) :lisp)
+(define-caller-pattern stringp (form) :lisp)
+(define-caller-pattern bit-vector-p (form) :lisp)
+(define-caller-pattern vectorp (form) :lisp)
+(define-caller-pattern simple-vector-p (form) :lisp)
+(define-caller-pattern simple-string-p (form) :lisp)
+(define-caller-pattern simple-bit-vector-p (form) :lisp)
+(define-caller-pattern arrayp (form) :lisp)
+(define-caller-pattern packagep (form) :lisp)
+(define-caller-pattern functionp (form) :lisp)
+(define-caller-pattern compiled-function-p (form) :lisp)
+(define-caller-pattern commonp (form) :lisp)
+
+;;; Equality Predicates
+(define-caller-pattern eq (form form) :lisp)
+(define-caller-pattern eql (form form) :lisp)
+(define-caller-pattern equal (form form) :lisp)
+(define-caller-pattern equalp (form form) :lisp)
+
+;;; Logical Operators
+(define-caller-pattern not (form) :lisp)
+(define-caller-pattern or ((:star form)) :lisp)
+(define-caller-pattern and ((:star form)) :lisp)
+
+;;; Reference
+
+;;; Quote is a problem. In Defmacro & friends, we'd like to actually
+;;; look at the argument, 'cause it hides internal function calls
+;;; of the defmacro.
+(define-caller-pattern quote (:ignore) :lisp)
+
+(define-caller-pattern function ((:or fn form)) :lisp)
+(define-caller-pattern symbol-value (form) :lisp)
+(define-caller-pattern symbol-function (form) :lisp)
+(define-caller-pattern fdefinition (form) :lisp2)
+(define-caller-pattern boundp (form) :lisp)
+(define-caller-pattern fboundp (form) :lisp)
+(define-caller-pattern special-form-p (form) :lisp)
+
+;;; Assignment
+(define-caller-pattern setq ((:star var form)) :lisp)
+(define-caller-pattern psetq ((:star var form)) :lisp)
+(define-caller-pattern set (form form) :lisp)
+(define-caller-pattern makunbound (form) :lisp)
+(define-caller-pattern fmakunbound (form) :lisp)
+
+;;; Generalized Variables
+(define-caller-pattern setf ((:star form form)) :lisp)
+(define-caller-pattern psetf ((:star form form)) :lisp)
+(define-caller-pattern shiftf ((:plus form) form) :lisp)
+(define-caller-pattern rotatef ((:star form)) :lisp)
+(define-caller-pattern define-modify-macro
+ (name
+ lambda-list
+ fn
+ (:optional documentation-string))
+ :lisp)
+(define-caller-pattern defsetf
+ (:or (name name (:optional documentation-string))
+ (name lambda-list (var)
+ (:star (:or declaration documentation-string))
+ (:star form)))
+ :lisp)
+(define-caller-pattern define-setf-method
+ (name lambda-list
+ (:star (:or declaration documentation-string))
+ (:star form))
+ :lisp)
+(define-caller-pattern get-setf-method (form) :lisp)
+(define-caller-pattern get-setf-method-multiple-value (form) :lisp)
+
+
+;;; Function invocation
+(define-caller-pattern apply (fn form (:star form)) :lisp)
+(define-caller-pattern funcall (fn (:star form)) :lisp)
+
+
+;;; Simple sequencing
+(define-caller-pattern progn ((:star form)) :lisp)
+(define-caller-pattern prog1 (form (:star form)) :lisp)
+(define-caller-pattern prog2 (form form (:star form)) :lisp)
+
+;;; Variable bindings
+(define-caller-pattern let
+ (((:star (:or var (var &optional form))))
+ (:star declaration)
+ (:star form))
+ :lisp)
+(define-caller-pattern let*
+ (((:star (:or var (var &optional form))))
+ (:star declaration)
+ (:star form))
+ :lisp)
+(define-caller-pattern compiler-let
+ (((:star (:or var (var form))))
+ (:star form))
+ :lisp)
+(define-caller-pattern progv
+ (form form (:star form)) :lisp)
+(define-caller-pattern flet
+ (((:star (name lambda-list
+ (:star (:or declaration
+ documentation-string))
+ (:star form))))
+ (:star form))
+ :lisp)
+(define-caller-pattern labels
+ (((:star (name lambda-list
+ (:star (:or declaration
+ documentation-string))
+ (:star form))))
+ (:star form))
+ :lisp)
+(define-caller-pattern macrolet
+ (((:star (name lambda-list
+ (:star (:or declaration
+ documentation-string))
+ (:star form))))
+ (:star form))
+ :lisp)
+(define-caller-pattern symbol-macrolet
+ (((:star (var form))) (:star declaration) (:star form))
+ :lisp2)
+
+;;; Conditionals
+(define-caller-pattern if (test form (:optional form)) :lisp)
+(define-caller-pattern when (test (:star form)) :lisp)
+(define-caller-pattern unless (test (:star form)) :lisp)
+(define-caller-pattern cond ((:star (test (:star form)))) :lisp)
+(define-caller-pattern case
+ (form
+ (:star ((:or symbol
+ ((:star symbol)))
+ (:star form))))
+ :lisp)
+(define-caller-pattern typecase (form (:star (symbol (:star form))))
+ :lisp)
+
+;;; Blocks and Exits
+(define-caller-pattern block (name (:star form)) :lisp)
+(define-caller-pattern return-from (function (:optional form)) :lisp)
+(define-caller-pattern return ((:optional form)) :lisp)
+
+;;; Iteration
+(define-caller-pattern loop ((:star form)) :lisp)
+(define-caller-pattern do
+ (((:star (:or var
+ (var (:optional form (:optional form)))))) ; init step
+ (form (:star form)) ; end-test result
+ (:star declaration)
+ (:star (:or tag form))) ; statement
+ :lisp)
+(define-caller-pattern do*
+ (((:star (:or var
+ (var (:optional form (:optional form))))))
+ (form (:star form))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern dolist
+ ((var form (:optional form))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern dotimes
+ ((var form (:optional form))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+
+;;; Mapping
+(define-caller-pattern mapcar (fn form (:star form)) :lisp)
+(define-caller-pattern maplist (fn form (:star form)) :lisp)
+(define-caller-pattern mapc (fn form (:star form)) :lisp)
+(define-caller-pattern mapl (fn form (:star form)) :lisp)
+(define-caller-pattern mapcan (fn form (:star form)) :lisp)
+(define-caller-pattern mapcon (fn form (:star form)) :lisp)
+
+;;; The "Program Feature"
+(define-caller-pattern tagbody ((:star (:or tag form))) :lisp)
+(define-caller-pattern prog
+ (((:star (:or var (var (:optional form)))))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern prog*
+ (((:star (:or var (var (:optional form)))))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern go (tag) :lisp)
+
+;;; Multiple Values
+(define-caller-pattern values ((:star form)) :lisp)
+(define-variable-pattern multiple-values-limit :lisp)
+(define-caller-pattern values-list (form) :lisp)
+(define-caller-pattern multiple-value-list (form) :lisp)
+(define-caller-pattern multiple-value-call (fn (:star form)) :lisp)
+(define-caller-pattern multiple-value-prog1 (form (:star form)) :lisp)
+(define-caller-pattern multiple-value-bind
+ (((:star var)) form
+ (:star declaration)
+ (:star form))
+ :lisp)
+(define-caller-pattern multiple-value-setq (((:star var)) form) :lisp)
+(define-caller-pattern nth-value (form form) :lisp2)
+
+;;; Dynamic Non-Local Exits
+(define-caller-pattern catch (tag (:star form)) :lisp)
+(define-caller-pattern throw (tag form) :lisp)
+(define-caller-pattern unwind-protect (form (:star form)) :lisp)
+
+;;; Macros
+(define-caller-pattern macro-function (form) :lisp)
+(define-caller-pattern defmacro
+ (name
+ lambda-list
+ (:star (:or declaration documentation-string))
+ (:star form))
+ :lisp)
+(define-caller-pattern macroexpand (form (:optional :ignore)) :lisp)
+(define-caller-pattern macroexpand-1 (form (:optional :ignore)) :lisp)
+(define-variable-pattern *macroexpand-hook* :lisp)
+
+;;; Destructuring
+(define-caller-pattern destructuring-bind
+ (lambda-list form
+ (:star declaration)
+ (:star form))
+ :lisp2)
+
+;;; Compiler Macros
+(define-caller-pattern define-compiler-macro
+ (name lambda-list
+ (:star (:or declaration documentation-string))
+ (:star form))
+ :lisp2)
+(define-caller-pattern compiler-macro-function (form) :lisp2)
+(define-caller-pattern compiler-macroexpand (form (:optional :ignore)) :lisp2)
+(define-caller-pattern compiler-macroexpand-1 (form (:optional :ignore))
+ :lisp2)
+
+;;; Environments
+(define-caller-pattern variable-information (form &optional :ignore)
+ :lisp2)
+(define-caller-pattern function-information (fn &optional :ignore) :lisp2)
+(define-caller-pattern declaration-information (form &optional :ignore) :lisp2)
+(define-caller-pattern augment-environment (form &key (:star :ignore)) :lisp2)
+(define-caller-pattern define-declaration
+ (name
+ lambda-list
+ (:star form))
+ :lisp2)
+(define-caller-pattern parse-macro (name lambda-list form) :lisp2)
+(define-caller-pattern enclose (form &optional :ignore) :lisp2)
+
+
+;;; Declarations
+(define-caller-pattern declare ((:rest :ignore)) :lisp)
+(define-caller-pattern proclaim ((:rest :ignore)) :lisp)
+(define-caller-pattern locally ((:star declaration) (:star form)) :lisp)
+(define-caller-pattern declaim ((:rest :ignore)) :lisp2)
+(define-caller-pattern the (form form) :lisp)
+
+;;; Symbols
+(define-caller-pattern get (form form (:optional form)) :lisp)
+(define-caller-pattern remprop (form form) :lisp)
+(define-caller-pattern symbol-plist (form) :lisp)
+(define-caller-pattern getf (form form (:optional form)) :lisp)
+(define-caller-pattern remf (form form) :lisp)
+(define-caller-pattern get-properties (form form) :lisp)
+
+(define-caller-pattern symbol-name (form) :lisp)
+(define-caller-pattern make-symbol (form) :lisp)
+(define-caller-pattern copy-symbol (form (:optional :ignore)) :lisp)
+(define-caller-pattern gensym ((:optional :ignore)) :lisp)
+(define-variable-pattern *gensym-counter* :lisp2)
+(define-caller-pattern gentemp ((:optional :ignore :ignore)) :lisp)
+(define-caller-pattern symbol-package (form) :lisp)
+(define-caller-pattern keywordp (form) :lisp)
+
+;;; Packages
+(define-variable-pattern *package* :lisp)
+(define-caller-pattern make-package ((:rest :ignore)) :lisp)
+(define-caller-pattern in-package ((:rest :ignore)) :lisp)
+(define-caller-pattern find-package ((:rest :ignore)) :lisp)
+(define-caller-pattern package-name ((:rest :ignore)) :lisp)
+(define-caller-pattern package-nicknames ((:rest :ignore)) :lisp)
+(define-caller-pattern rename-package ((:rest :ignore)) :lisp)
+(define-caller-pattern package-use-list ((:rest :ignore)) :lisp)
+(define-caller-pattern package-used-by-list ((:rest :ignore)) :lisp)
+(define-caller-pattern package-shadowing-symbols ((:rest :ignore)) :lisp)
+(define-caller-pattern list-all-packages () :lisp)
+(define-caller-pattern delete-package ((:rest :ignore)) :lisp2)
+(define-caller-pattern intern (form &optional :ignore) :lisp)
+(define-caller-pattern find-symbol (form &optional :ignore) :lisp)
+(define-caller-pattern unintern (form &optional :ignore) :lisp)
+
+(define-caller-pattern export ((:or symbol ((:star symbol)))
+ &optional :ignore) :lisp)
+(define-caller-pattern unexport ((:or symbol ((:star symbol)))
+ &optional :ignore) :lisp)
+(define-caller-pattern import ((:or symbol ((:star symbol)))
+ &optional :ignore) :lisp)
+(define-caller-pattern shadowing-import ((:or symbol ((:star symbol)))
+ &optional :ignore) :lisp)
+(define-caller-pattern shadow ((:or symbol ((:star symbol)))
+ &optional :ignore) :lisp)
+
+(define-caller-pattern use-package ((:rest :ignore)) :lisp)
+(define-caller-pattern unuse-package ((:rest :ignore)) :lisp)
+(define-caller-pattern defpackage (name (:rest :ignore)) :lisp2)
+(define-caller-pattern find-all-symbols (form) :lisp)
+(define-caller-pattern do-symbols
+ ((var (:optional form (:optional form)))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern do-external-symbols
+ ((var (:optional form (:optional form)))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern do-all-symbols
+ ((var (:optional form))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern with-package-iterator
+ ((name form (:plus :ignore))
+ (:star form))
+ :lisp2)
+
+;;; Modules
+(define-variable-pattern *modules* :lisp)
+(define-caller-pattern provide (form) :lisp)
+(define-caller-pattern require (form &optional :ignore) :lisp)
+
+
+;;; Numbers
+(define-caller-pattern zerop (form) :lisp)
+(define-caller-pattern plusp (form) :lisp)
+(define-caller-pattern minusp (form) :lisp)
+(define-caller-pattern oddp (form) :lisp)
+(define-caller-pattern evenp (form) :lisp)
+
+(define-caller-pattern = (form (:star form)) :lisp)
+(define-caller-pattern /= (form (:star form)) :lisp)
+(define-caller-pattern > (form (:star form)) :lisp)
+(define-caller-pattern < (form (:star form)) :lisp)
+(define-caller-pattern <= (form (:star form)) :lisp)
+(define-caller-pattern >= (form (:star form)) :lisp)
+
+(define-caller-pattern max (form (:star form)) :lisp)
+(define-caller-pattern min (form (:star form)) :lisp)
+
+(define-caller-pattern - (form (:star form)) :lisp)
+(define-caller-pattern + (form (:star form)) :lisp)
+(define-caller-pattern * (form (:star form)) :lisp)
+(define-caller-pattern / (form (:star form)) :lisp)
+(define-caller-pattern 1+ (form) :lisp)
+(define-caller-pattern 1- (form) :lisp)
+
+(define-caller-pattern incf (form form) :lisp)
+(define-caller-pattern decf (form form) :lisp)
+
+(define-caller-pattern conjugate (form) :lisp)
+
+(define-caller-pattern gcd ((:star form)) :lisp)
+(define-caller-pattern lcm ((:star form)) :lisp)
+
+(define-caller-pattern exp (form) :lisp)
+(define-caller-pattern expt (form form) :lisp)
+(define-caller-pattern log (form (:optional form)) :lisp)
+(define-caller-pattern sqrt (form) :lisp)
+(define-caller-pattern isqrt (form) :lisp)
+
+(define-caller-pattern abs (form) :lisp)
+(define-caller-pattern phase (form) :lisp)
+(define-caller-pattern signum (form) :lisp)
+(define-caller-pattern sin (form) :lisp)
+(define-caller-pattern cos (form) :lisp)
+(define-caller-pattern tan (form) :lisp)
+(define-caller-pattern cis (form) :lisp)
+(define-caller-pattern asin (form) :lisp)
+(define-caller-pattern acos (form) :lisp)
+(define-caller-pattern atan (form &optional form) :lisp)
+(define-variable-pattern pi :lisp)
+
+(define-caller-pattern sinh (form) :lisp)
+(define-caller-pattern cosh (form) :lisp)
+(define-caller-pattern tanh (form) :lisp)
+(define-caller-pattern asinh (form) :lisp)
+(define-caller-pattern acosh (form) :lisp)
+(define-caller-pattern atanh (form) :lisp)
+
+;;; Type Conversions and Extractions
+(define-caller-pattern float (form (:optional form)) :lisp)
+(define-caller-pattern rational (form) :lisp)
+(define-caller-pattern rationalize (form) :lisp)
+(define-caller-pattern numerator (form) :lisp)
+(define-caller-pattern denominator (form) :lisp)
+
+(define-caller-pattern floor (form (:optional form)) :lisp)
+(define-caller-pattern ceiling (form (:optional form)) :lisp)
+(define-caller-pattern truncate (form (:optional form)) :lisp)
+(define-caller-pattern round (form (:optional form)) :lisp)
+
+(define-caller-pattern mod (form form) :lisp)
+(define-caller-pattern rem (form form) :lisp)
+
+(define-caller-pattern ffloor (form (:optional form)) :lisp)
+(define-caller-pattern fceiling (form (:optional form)) :lisp)
+(define-caller-pattern ftruncate (form (:optional form)) :lisp)
+(define-caller-pattern fround (form (:optional form)) :lisp)
+
+(define-caller-pattern decode-float (form) :lisp)
+(define-caller-pattern scale-float (form form) :lisp)
+(define-caller-pattern float-radix (form) :lisp)
+(define-caller-pattern float-sign (form (:optional form)) :lisp)
+(define-caller-pattern float-digits (form) :lisp)
+(define-caller-pattern float-precision (form) :lisp)
+(define-caller-pattern integer-decode-float (form) :lisp)
+
+(define-caller-pattern complex (form (:optional form)) :lisp)
+(define-caller-pattern realpart (form) :lisp)
+(define-caller-pattern imagpart (form) :lisp)
+
+(define-caller-pattern logior ((:star form)) :lisp)
+(define-caller-pattern logxor ((:star form)) :lisp)
+(define-caller-pattern logand ((:star form)) :lisp)
+(define-caller-pattern logeqv ((:star form)) :lisp)
+
+(define-caller-pattern lognand (form form) :lisp)
+(define-caller-pattern lognor (form form) :lisp)
+(define-caller-pattern logandc1 (form form) :lisp)
+(define-caller-pattern logandc2 (form form) :lisp)
+(define-caller-pattern logorc1 (form form) :lisp)
+(define-caller-pattern logorc2 (form form) :lisp)
+
+(define-caller-pattern boole (form form form) :lisp)
+(define-variable-pattern boole-clr :lisp)
+(define-variable-pattern boole-set :lisp)
+(define-variable-pattern boole-1 :lisp)
+(define-variable-pattern boole-2 :lisp)
+(define-variable-pattern boole-c1 :lisp)
+(define-variable-pattern boole-c2 :lisp)
+(define-variable-pattern boole-and :lisp)
+(define-variable-pattern boole-ior :lisp)
+(define-variable-pattern boole-xor :lisp)
+(define-variable-pattern boole-eqv :lisp)
+(define-variable-pattern boole-nand :lisp)
+(define-variable-pattern boole-nor :lisp)
+(define-variable-pattern boole-andc1 :lisp)
+(define-variable-pattern boole-andc2 :lisp)
+(define-variable-pattern boole-orc1 :lisp)
+(define-variable-pattern boole-orc2 :lisp)
+
+(define-caller-pattern lognot (form) :lisp)
+(define-caller-pattern logtest (form form) :lisp)
+(define-caller-pattern logbitp (form form) :lisp)
+(define-caller-pattern ash (form form) :lisp)
+(define-caller-pattern logcount (form) :lisp)
+(define-caller-pattern integer-length (form) :lisp)
+
+(define-caller-pattern byte (form form) :lisp)
+(define-caller-pattern byte-size (form) :lisp)
+(define-caller-pattern byte-position (form) :lisp)
+(define-caller-pattern ldb (form form) :lisp)
+(define-caller-pattern ldb-test (form form) :lisp)
+(define-caller-pattern mask-field (form form) :lisp)
+(define-caller-pattern dpb (form form form) :lisp)
+(define-caller-pattern deposit-field (form form form) :lisp)
+
+;;; Random Numbers
+(define-caller-pattern random (form (:optional form)) :lisp)
+(define-variable-pattern *random-state* :lisp)
+(define-caller-pattern make-random-state ((:optional form)) :lisp)
+(define-caller-pattern random-state-p (form) :lisp)
+
+;;; Implementation Parameters
+(define-variable-pattern most-positive-fixnum :lisp)
+(define-variable-pattern most-negative-fixnum :lisp)
+(define-variable-pattern most-positive-short-float :lisp)
+(define-variable-pattern least-positive-short-float :lisp)
+(define-variable-pattern least-negative-short-float :lisp)
+(define-variable-pattern most-negative-short-float :lisp)
+(define-variable-pattern most-positive-single-float :lisp)
+(define-variable-pattern least-positive-single-float :lisp)
+(define-variable-pattern least-negative-single-float :lisp)
+(define-variable-pattern most-negative-single-float :lisp)
+(define-variable-pattern most-positive-double-float :lisp)
+(define-variable-pattern least-positive-double-float :lisp)
+(define-variable-pattern least-negative-double-float :lisp)
+(define-variable-pattern most-negative-double-float :lisp)
+(define-variable-pattern most-positive-long-float :lisp)
+(define-variable-pattern least-positive-long-float :lisp)
+(define-variable-pattern least-negative-long-float :lisp)
+(define-variable-pattern most-negative-long-float :lisp)
+(define-variable-pattern least-positive-normalized-short-float :lisp2)
+(define-variable-pattern least-negative-normalized-short-float :lisp2)
+(define-variable-pattern least-positive-normalized-single-float :lisp2)
+(define-variable-pattern least-negative-normalized-single-float :lisp2)
+(define-variable-pattern least-positive-normalized-double-float :lisp2)
+(define-variable-pattern least-negative-normalized-double-float :lisp2)
+(define-variable-pattern least-positive-normalized-long-float :lisp2)
+(define-variable-pattern least-negative-normalized-long-float :lisp2)
+(define-variable-pattern short-float-epsilon :lisp)
+(define-variable-pattern single-float-epsilon :lisp)
+(define-variable-pattern double-float-epsilon :lisp)
+(define-variable-pattern long-float-epsilon :lisp)
+(define-variable-pattern short-float-negative-epsilon :lisp)
+(define-variable-pattern single-float-negative-epsilon :lisp)
+(define-variable-pattern double-float-negative-epsilon :lisp)
+(define-variable-pattern long-float-negative-epsilon :lisp)
+
+;;; Characters
+(define-variable-pattern char-code-limit :lisp)
+(define-variable-pattern char-font-limit :lisp)
+(define-variable-pattern char-bits-limit :lisp)
+(define-caller-pattern standard-char-p (form) :lisp)
+(define-caller-pattern graphic-char-p (form) :lisp)
+(define-caller-pattern string-char-p (form) :lisp)
+(define-caller-pattern alpha-char-p (form) :lisp)
+(define-caller-pattern upper-case-p (form) :lisp)
+(define-caller-pattern lower-case-p (form) :lisp)
+(define-caller-pattern both-case-p (form) :lisp)
+(define-caller-pattern digit-char-p (form (:optional form)) :lisp)
+(define-caller-pattern alphanumericp (form) :lisp)
+
+(define-caller-pattern char= ((:star form)) :lisp)
+(define-caller-pattern char/= ((:star form)) :lisp)
+(define-caller-pattern char< ((:star form)) :lisp)
+(define-caller-pattern char> ((:star form)) :lisp)
+(define-caller-pattern char<= ((:star form)) :lisp)
+(define-caller-pattern char>= ((:star form)) :lisp)
+
+(define-caller-pattern char-equal ((:star form)) :lisp)
+(define-caller-pattern char-not-equal ((:star form)) :lisp)
+(define-caller-pattern char-lessp ((:star form)) :lisp)
+(define-caller-pattern char-greaterp ((:star form)) :lisp)
+(define-caller-pattern char-not-greaterp ((:star form)) :lisp)
+(define-caller-pattern char-not-lessp ((:star form)) :lisp)
+
+(define-caller-pattern char-code (form) :lisp)
+(define-caller-pattern char-bits (form) :lisp)
+(define-caller-pattern char-font (form) :lisp)
+(define-caller-pattern code-char (form (:optional form form)) :lisp)
+(define-caller-pattern make-char (form (:optional form form)) :lisp)
+(define-caller-pattern characterp (form) :lisp)
+(define-caller-pattern char-upcase (form) :lisp)
+(define-caller-pattern char-downcase (form) :lisp)
+(define-caller-pattern digit-char (form (:optional form form)) :lisp)
+(define-caller-pattern char-int (form) :lisp)
+(define-caller-pattern int-char (form) :lisp)
+(define-caller-pattern char-name (form) :lisp)
+(define-caller-pattern name-char (form) :lisp)
+(define-variable-pattern char-control-bit :lisp)
+(define-variable-pattern char-meta-bit :lisp)
+(define-variable-pattern char-super-bit :lisp)
+(define-variable-pattern char-hyper-bit :lisp)
+(define-caller-pattern char-bit (form form) :lisp)
+(define-caller-pattern set-char-bit (form form form) :lisp)
+
+;;; Sequences
+(define-caller-pattern complement (fn) :lisp2)
+(define-caller-pattern elt (form form) :lisp)
+(define-caller-pattern subseq (form form &optional form) :lisp)
+(define-caller-pattern copy-seq (form) :lisp)
+(define-caller-pattern length (form) :lisp)
+(define-caller-pattern reverse (form) :lisp)
+(define-caller-pattern nreverse (form) :lisp)
+(define-caller-pattern make-sequence (form form &key form) :lisp)
+
+(define-caller-pattern concatenate (form (:star form)) :lisp)
+(define-caller-pattern map (form fn form (:star form)) :lisp)
+(define-caller-pattern map-into (form fn (:star form)) :lisp2)
+
+(define-caller-pattern some (fn form (:star form)) :lisp)
+(define-caller-pattern every (fn form (:star form)) :lisp)
+(define-caller-pattern notany (fn form (:star form)) :lisp)
+(define-caller-pattern notevery (fn form (:star form)) :lisp)
+
+(define-caller-pattern reduce (fn form &key (:star form)) :lisp)
+(define-caller-pattern fill (form form &key (:star form)) :lisp)
+(define-caller-pattern replace (form form &key (:star form)) :lisp)
+(define-caller-pattern remove (form form &key (:star form)) :lisp)
+(define-caller-pattern remove-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern remove-if-not (fn form &key (:star form)) :lisp)
+(define-caller-pattern delete (form form &key (:star form)) :lisp)
+(define-caller-pattern delete-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern delete-if-not (fn form &key (:star form)) :lisp)
+(define-caller-pattern remove-duplicates (form &key (:star form)) :lisp)
+(define-caller-pattern delete-duplicates (form &key (:star form)) :lisp)
+(define-caller-pattern substitute (form form form &key (:star form)) :lisp)
+(define-caller-pattern substitute-if (form fn form &key (:star form)) :lisp)
+(define-caller-pattern substitute-if-not (form fn form &key (:star form))
+ :lisp)
+(define-caller-pattern nsubstitute (form form form &key (:star form)) :lisp)
+(define-caller-pattern nsubstitute-if (form fn form &key (:star form)) :lisp)
+(define-caller-pattern nsubstitute-if-not (form fn form &key (:star form))
+ :lisp)
+(define-caller-pattern find (form form &key (:star form)) :lisp)
+(define-caller-pattern find-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern find-if-not (fn form &key (:star form)) :lisp)
+(define-caller-pattern position (form form &key (:star form)) :lisp)
+(define-caller-pattern position-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern position-if-not (fn form &key (:star form)) :lisp)
+(define-caller-pattern count (form form &key (:star form)) :lisp)
+(define-caller-pattern count-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern count-if-not (fn form &key (:star form)) :lisp)
+(define-caller-pattern mismatch (form form &key (:star form)) :lisp)
+(define-caller-pattern search (form form &key (:star form)) :lisp)
+(define-caller-pattern sort (form fn &key (:star form)) :lisp)
+(define-caller-pattern stable-sort (form fn &key (:star form)) :lisp)
+(define-caller-pattern merge (form form form fn &key (:star form)) :lisp)
+
+;;; Lists
+(define-caller-pattern car (form) :lisp)
+(define-caller-pattern cdr (form) :lisp)
+(define-caller-pattern caar (form) :lisp)
+(define-caller-pattern cadr (form) :lisp)
+(define-caller-pattern cdar (form) :lisp)
+(define-caller-pattern cddr (form) :lisp)
+(define-caller-pattern caaar (form) :lisp)
+(define-caller-pattern caadr (form) :lisp)
+(define-caller-pattern cadar (form) :lisp)
+(define-caller-pattern caddr (form) :lisp)
+(define-caller-pattern cdaar (form) :lisp)
+(define-caller-pattern cdadr (form) :lisp)
+(define-caller-pattern cddar (form) :lisp)
+(define-caller-pattern cdddr (form) :lisp)
+(define-caller-pattern caaaar (form) :lisp)
+(define-caller-pattern caaadr (form) :lisp)
+(define-caller-pattern caadar (form) :lisp)
+(define-caller-pattern caaddr (form) :lisp)
+(define-caller-pattern cadaar (form) :lisp)
+(define-caller-pattern cadadr (form) :lisp)
+(define-caller-pattern caddar (form) :lisp)
+(define-caller-pattern cadddr (form) :lisp)
+(define-caller-pattern cdaaar (form) :lisp)
+(define-caller-pattern cdaadr (form) :lisp)
+(define-caller-pattern cdadar (form) :lisp)
+(define-caller-pattern cdaddr (form) :lisp)
+(define-caller-pattern cddaar (form) :lisp)
+(define-caller-pattern cddadr (form) :lisp)
+(define-caller-pattern cdddar (form) :lisp)
+(define-caller-pattern cddddr (form) :lisp)
+
+(define-caller-pattern cons (form form) :lisp)
+(define-caller-pattern tree-equal (form form &key (:star fn)) :lisp)
+(define-caller-pattern endp (form) :lisp)
+(define-caller-pattern list-length (form) :lisp)
+(define-caller-pattern nth (form form) :lisp)
+
+(define-caller-pattern first (form) :lisp)
+(define-caller-pattern second (form) :lisp)
+(define-caller-pattern third (form) :lisp)
+(define-caller-pattern fourth (form) :lisp)
+(define-caller-pattern fifth (form) :lisp)
+(define-caller-pattern sixth (form) :lisp)
+(define-caller-pattern seventh (form) :lisp)
+(define-caller-pattern eighth (form) :lisp)
+(define-caller-pattern ninth (form) :lisp)
+(define-caller-pattern tenth (form) :lisp)
+
+(define-caller-pattern rest (form) :lisp)
+(define-caller-pattern nthcdr (form form) :lisp)
+(define-caller-pattern last (form (:optional form)) :lisp)
+(define-caller-pattern list ((:star form)) :lisp)
+(define-caller-pattern list* ((:star form)) :lisp)
+(define-caller-pattern make-list (form &key (:star form)) :lisp)
+(define-caller-pattern append ((:star form)) :lisp)
+(define-caller-pattern copy-list (form) :lisp)
+(define-caller-pattern copy-alist (form) :lisp)
+(define-caller-pattern copy-tree (form) :lisp)
+(define-caller-pattern revappend (form form) :lisp)
+(define-caller-pattern nconc ((:star form)) :lisp)
+(define-caller-pattern nreconc (form form) :lisp)
+(define-caller-pattern push (form form) :lisp)
+(define-caller-pattern pushnew (form form &key (:star form)) :lisp)
+(define-caller-pattern pop (form) :lisp)
+(define-caller-pattern butlast (form (:optional form)) :lisp)
+(define-caller-pattern nbutlast (form (:optional form)) :lisp)
+(define-caller-pattern ldiff (form form) :lisp)
+(define-caller-pattern rplaca (form form) :lisp)
+(define-caller-pattern rplacd (form form) :lisp)
+
+(define-caller-pattern subst (form form form &key (:star form)) :lisp)
+(define-caller-pattern subst-if (form fn form &key (:star form)) :lisp)
+(define-caller-pattern subst-if-not (form fn form &key (:star form)) :lisp)
+(define-caller-pattern nsubst (form form form &key (:star form)) :lisp)
+(define-caller-pattern nsubst-if (form fn form &key (:star form)) :lisp)
+(define-caller-pattern nsubst-if-not (form fn form &key (:star form)) :lisp)
+(define-caller-pattern sublis (form form &key (:star form)) :lisp)
+(define-caller-pattern nsublis (form form &key (:star form)) :lisp)
+(define-caller-pattern member (form form &key (:star form)) :lisp)
+(define-caller-pattern member-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern member-if-not (fn form &key (:star form)) :lisp)
+
+(define-caller-pattern tailp (form form) :lisp)
+(define-caller-pattern adjoin (form form &key (:star form)) :lisp)
+(define-caller-pattern union (form form &key (:star form)) :lisp)
+(define-caller-pattern nunion (form form &key (:star form)) :lisp)
+(define-caller-pattern intersection (form form &key (:star form)) :lisp)
+(define-caller-pattern nintersection (form form &key (:star form)) :lisp)
+(define-caller-pattern set-difference (form form &key (:star form)) :lisp)
+(define-caller-pattern nset-difference (form form &key (:star form)) :lisp)
+(define-caller-pattern set-exclusive-or (form form &key (:star form)) :lisp)
+(define-caller-pattern nset-exclusive-or (form form &key (:star form)) :lisp)
+(define-caller-pattern subsetp (form form &key (:star form)) :lisp)
+
+(define-caller-pattern acons (form form form) :lisp)
+(define-caller-pattern pairlis (form form (:optional form)) :lisp)
+(define-caller-pattern assoc (form form &key (:star form)) :lisp)
+(define-caller-pattern assoc-if (fn form) :lisp)
+(define-caller-pattern assoc-if-not (fn form) :lisp)
+(define-caller-pattern rassoc (form form &key (:star form)) :lisp)
+(define-caller-pattern rassoc-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern rassoc-if-not (fn form &key (:star form)) :lisp)
+
+;;; Hash Tables
+(define-caller-pattern make-hash-table (&key (:star form)) :lisp)
+(define-caller-pattern hash-table-p (form) :lisp)
+(define-caller-pattern gethash (form form (:optional form)) :lisp)
+(define-caller-pattern remhash (form form) :lisp)
+(define-caller-pattern maphash (fn form) :lisp)
+(define-caller-pattern clrhash (form) :lisp)
+(define-caller-pattern hash-table-count (form) :lisp)
+(define-caller-pattern with-hash-table-iterator
+ ((name form) (:star form)) :lisp2)
+(define-caller-pattern hash-table-rehash-size (form) :lisp2)
+(define-caller-pattern hash-table-rehash-threshold (form) :lisp2)
+(define-caller-pattern hash-table-size (form) :lisp2)
+(define-caller-pattern hash-table-test (form) :lisp2)
+(define-caller-pattern sxhash (form) :lisp)
+
+;;; Arrays
+(define-caller-pattern make-array (form &key (:star form)) :lisp)
+(define-variable-pattern array-rank-limit :lisp)
+(define-variable-pattern array-dimension-limit :lisp)
+(define-variable-pattern array-total-size-limit :lisp)
+(define-caller-pattern vector ((:star form)) :lisp)
+(define-caller-pattern aref (form (:star form)) :lisp)
+(define-caller-pattern svref (form form) :lisp)
+(define-caller-pattern array-element-type (form) :lisp)
+(define-caller-pattern array-rank (form) :lisp)
+(define-caller-pattern array-dimension (form form) :lisp)
+(define-caller-pattern array-dimensions (form) :lisp)
+(define-caller-pattern array-total-size (form) :lisp)
+(define-caller-pattern array-in-bounds-p (form (:star form)) :lisp)
+(define-caller-pattern array-row-major-index (form (:star form)) :lisp)
+(define-caller-pattern row-major-aref (form form) :lisp2)
+(define-caller-pattern adjustable-array-p (form) :lisp)
+
+(define-caller-pattern bit (form (:star form)) :lisp)
+(define-caller-pattern sbit (form (:star form)) :lisp)
+
+(define-caller-pattern bit-and (form form (:optional form)) :lisp)
+(define-caller-pattern bit-ior (form form (:optional form)) :lisp)
+(define-caller-pattern bit-xor (form form (:optional form)) :lisp)
+(define-caller-pattern bit-eqv (form form (:optional form)) :lisp)
+(define-caller-pattern bit-nand (form form (:optional form)) :lisp)
+(define-caller-pattern bit-nor (form form (:optional form)) :lisp)
+(define-caller-pattern bit-andc1 (form form (:optional form)) :lisp)
+(define-caller-pattern bit-andc2 (form form (:optional form)) :lisp)
+(define-caller-pattern bit-orc1 (form form (:optional form)) :lisp)
+(define-caller-pattern bit-orc2 (form form (:optional form)) :lisp)
+(define-caller-pattern bit-not (form (:optional form)) :lisp)
+
+(define-caller-pattern array-has-fill-pointer-p (form) :lisp)
+(define-caller-pattern fill-pointer (form) :lisp)
+(define-caller-pattern vector-push (form form) :lisp)
+(define-caller-pattern vector-push-extend (form form (:optional form)) :lisp)
+(define-caller-pattern vector-pop (form) :lisp)
+(define-caller-pattern adjust-array (form form &key (:star form)) :lisp)
+
+;;; Strings
+(define-caller-pattern char (form form) :lisp)
+(define-caller-pattern schar (form form) :lisp)
+(define-caller-pattern string= (form form &key (:star form)) :lisp)
+(define-caller-pattern string-equal (form form &key (:star form)) :lisp)
+(define-caller-pattern string< (form form &key (:star form)) :lisp)
+(define-caller-pattern string> (form form &key (:star form)) :lisp)
+(define-caller-pattern string<= (form form &key (:star form)) :lisp)
+(define-caller-pattern string>= (form form &key (:star form)) :lisp)
+(define-caller-pattern string/= (form form &key (:star form)) :lisp)
+(define-caller-pattern string-lessp (form form &key (:star form)) :lisp)
+(define-caller-pattern string-greaterp (form form &key (:star form)) :lisp)
+(define-caller-pattern string-not-greaterp (form form &key (:star form)) :lisp)
+(define-caller-pattern string-not-lessp (form form &key (:star form)) :lisp)
+(define-caller-pattern string-not-equal (form form &key (:star form)) :lisp)
+
+(define-caller-pattern make-string (form &key (:star form)) :lisp)
+(define-caller-pattern string-trim (form form) :lisp)
+(define-caller-pattern string-left-trim (form form) :lisp)
+(define-caller-pattern string-right-trim (form form) :lisp)
+(define-caller-pattern string-upcase (form &key (:star form)) :lisp)
+(define-caller-pattern string-downcase (form &key (:star form)) :lisp)
+(define-caller-pattern string-capitalize (form &key (:star form)) :lisp)
+(define-caller-pattern nstring-upcase (form &key (:star form)) :lisp)
+(define-caller-pattern nstring-downcase (form &key (:star form)) :lisp)
+(define-caller-pattern nstring-capitalize (form &key (:star form)) :lisp)
+(define-caller-pattern string (form) :lisp)
+
+;;; Structures
+(define-caller-pattern defstruct
+ ((:or name (name (:rest :ignore)))
+ (:optional documentation-string)
+ (:plus :ignore))
+ :lisp)
+
+;;; The Evaluator
+(define-caller-pattern eval (form) :lisp)
+(define-variable-pattern *evalhook* :lisp)
+(define-variable-pattern *applyhook* :lisp)
+(define-caller-pattern evalhook (form fn fn &optional :ignore) :lisp)
+(define-caller-pattern applyhook (fn form fn fn &optional :ignore) :lisp)
+(define-caller-pattern constantp (form) :lisp)
+
+;;; Streams
+(define-variable-pattern *standard-input* :lisp)
+(define-variable-pattern *standard-output* :lisp)
+(define-variable-pattern *error-output* :lisp)
+(define-variable-pattern *query-io* :lisp)
+(define-variable-pattern *debug-io* :lisp)
+(define-variable-pattern *terminal-io* :lisp)
+(define-variable-pattern *trace-output* :lisp)
+(define-caller-pattern make-synonym-stream (symbol) :lisp)
+(define-caller-pattern make-broadcast-stream ((:star form)) :lisp)
+(define-caller-pattern make-concatenated-stream ((:star form)) :lisp)
+(define-caller-pattern make-two-way-stream (form form) :lisp)
+(define-caller-pattern make-echo-stream (form form) :lisp)
+(define-caller-pattern make-string-input-stream (form &optional form form)
+ :lisp)
+(define-caller-pattern make-string-output-stream (&key (:star form)) :lisp)
+(define-caller-pattern get-output-stream-string (form) :lisp)
+
+(define-caller-pattern with-open-stream
+ ((var form)
+ (:star declaration)
+ (:star form))
+ :lisp)
+
+(define-caller-pattern with-input-from-string
+ ((var form &key (:star form))
+ (:star declaration)
+ (:star form))
+ :lisp)
+
+(define-caller-pattern with-output-to-string
+ ((var (:optional form))
+ (:star declaration)
+ (:star form))
+ :lisp)
+(define-caller-pattern streamp (form) :lisp)
+(define-caller-pattern open-stream-p (form) :lisp2)
+(define-caller-pattern input-stream-p (form) :lisp)
+(define-caller-pattern output-stream-p (form) :lisp)
+(define-caller-pattern stream-element-type (form) :lisp)
+(define-caller-pattern close (form (:rest :ignore)) :lisp)
+(define-caller-pattern broadcast-stream-streams (form) :lisp2)
+(define-caller-pattern concatenated-stream-streams (form) :lisp2)
+(define-caller-pattern echo-stream-input-stream (form) :lisp2)
+(define-caller-pattern echo-stream-output-stream (form) :lisp2)
+(define-caller-pattern synonym-stream-symbol (form) :lisp2)
+(define-caller-pattern two-way-stream-input-stream (form) :lisp2)
+(define-caller-pattern two-way-stream-output-stream (form) :lisp2)
+(define-caller-pattern interactive-stream-p (form) :lisp2)
+(define-caller-pattern stream-external-format (form) :lisp2)
+
+;;; Reader
+(define-variable-pattern *read-base* :lisp)
+(define-variable-pattern *read-suppress* :lisp)
+(define-variable-pattern *read-eval* :lisp2)
+(define-variable-pattern *readtable* :lisp)
+(define-caller-pattern copy-readtable (&optional form form) :lisp)
+(define-caller-pattern readtablep (form) :lisp)
+(define-caller-pattern set-syntax-from-char (form form &optional form form)
+ :lisp)
+(define-caller-pattern set-macro-character (form fn &optional form) :lisp)
+(define-caller-pattern get-macro-character (form (:optional form)) :lisp)
+(define-caller-pattern make-dispatch-macro-character (form &optional form form)
+ :lisp)
+(define-caller-pattern set-dispatch-macro-character
+ (form form fn (:optional form)) :lisp)
+(define-caller-pattern get-dispatch-macro-character
+ (form form (:optional form)) :lisp)
+(define-caller-pattern readtable-case (form) :lisp2)
+(define-variable-pattern *print-readably* :lisp2)
+(define-variable-pattern *print-escape* :lisp)
+(define-variable-pattern *print-pretty* :lisp)
+(define-variable-pattern *print-circle* :lisp)
+(define-variable-pattern *print-base* :lisp)
+(define-variable-pattern *print-radix* :lisp)
+(define-variable-pattern *print-case* :lisp)
+(define-variable-pattern *print-gensym* :lisp)
+(define-variable-pattern *print-level* :lisp)
+(define-variable-pattern *print-length* :lisp)
+(define-variable-pattern *print-array* :lisp)
+(define-caller-pattern with-standard-io-syntax
+ ((:star declaration)
+ (:star form))
+ :lisp2)
+
+(define-caller-pattern read (&optional form form form form) :lisp)
+(define-variable-pattern *read-default-float-format* :lisp)
+(define-caller-pattern read-preserving-whitespace
+ (&optional form form form form) :lisp)
+(define-caller-pattern read-delimited-list (form &optional form form) :lisp)
+(define-caller-pattern read-line (&optional form form form form) :lisp)
+(define-caller-pattern read-char (&optional form form form form) :lisp)
+(define-caller-pattern unread-char (form (:optional form)) :lisp)
+(define-caller-pattern peek-char (&optional form form form form) :lisp)
+(define-caller-pattern listen ((:optional form)) :lisp)
+(define-caller-pattern read-char-no-hang ((:star form)) :lisp)
+(define-caller-pattern clear-input ((:optional form)) :lisp)
+(define-caller-pattern read-from-string (form (:star form)) :lisp)
+(define-caller-pattern parse-integer (form &rest :ignore) :lisp)
+(define-caller-pattern read-byte ((:star form)) :lisp)
+
+(define-caller-pattern write (form &key (:star form)) :lisp)
+(define-caller-pattern prin1 (form (:optional form)) :lisp)
+(define-caller-pattern print (form (:optional form)) :lisp)
+(define-caller-pattern pprint (form (:optional form)) :lisp)
+(define-caller-pattern princ (form (:optional form)) :lisp)
+(define-caller-pattern write-to-string (form &key (:star form)) :lisp)
+(define-caller-pattern prin1-to-string (form) :lisp)
+(define-caller-pattern princ-to-string (form) :lisp)
+(define-caller-pattern write-char (form (:optional form)) :lisp)
+(define-caller-pattern write-string (form &optional form &key (:star form))
+ :lisp)
+(define-caller-pattern write-line (form &optional form &key (:star form))
+ :lisp)
+(define-caller-pattern terpri ((:optional form)) :lisp)
+(define-caller-pattern fresh-line ((:optional form)) :lisp)
+(define-caller-pattern finish-output ((:optional form)) :lisp)
+(define-caller-pattern force-output ((:optional form)) :lisp)
+(define-caller-pattern clear-output ((:optional form)) :lisp)
+(define-caller-pattern print-unreadable-object
+ ((form form &key (:star form))
+ (:star declaration)
+ (:star form))
+ :lisp2)
+(define-caller-pattern write-byte (form form) :lisp)
+(define-caller-pattern format
+ (destination
+ control-string
+ (:rest format-arguments))
+ :lisp)
+
+(define-caller-pattern y-or-n-p (control-string (:star form)) :lisp)
+(define-caller-pattern yes-or-no-p (control-string (:star form)) :lisp)
+
+;;; Pathnames
+(define-caller-pattern wild-pathname-p (form &optional form) :lisp2)
+(define-caller-pattern pathname-match-p (form form) :lisp2)
+(define-caller-pattern translate-pathname (form form form &key (:star form))
+ :lisp2)
+
+(define-caller-pattern logical-pathname (form) :lisp2)
+(define-caller-pattern translate-logical-pathname (form &key (:star form))
+ :lisp2)
+(define-caller-pattern logical-pathname-translations (form) :lisp2)
+(define-caller-pattern load-logical-pathname-translations (form) :lisp2)
+(define-caller-pattern compile-file-pathname (form &key form) :lisp2)
+
+(define-caller-pattern pathname (form) :lisp)
+(define-caller-pattern truename (form) :lisp)
+(define-caller-pattern parse-namestring ((:star form)) :lisp)
+(define-caller-pattern merge-pathnames ((:star form)) :lisp)
+(define-variable-pattern *default-pathname-defaults* :lisp)
+(define-caller-pattern make-pathname ((:star form)) :lisp)
+(define-caller-pattern pathnamep (form) :lisp)
+(define-caller-pattern pathname-host (form) :lisp)
+(define-caller-pattern pathname-device (form) :lisp)
+(define-caller-pattern pathname-directory (form) :lisp)
+(define-caller-pattern pathname-name (form) :lisp)
+(define-caller-pattern pathname-type (form) :lisp)
+(define-caller-pattern pathname-version (form) :lisp)
+(define-caller-pattern namestring (form) :lisp)
+(define-caller-pattern file-namestring (form) :lisp)
+(define-caller-pattern directory-namestring (form) :lisp)
+(define-caller-pattern host-namestring (form) :lisp)
+(define-caller-pattern enough-namestring (form (:optional form)) :lisp)
+(define-caller-pattern user-homedir-pathname (&optional form) :lisp)
+(define-caller-pattern open (form &key (:star form)) :lisp)
+(define-caller-pattern with-open-file
+ ((var form (:rest :ignore))
+ (:star declaration)
+ (:star form))
+ :lisp)
+
+(define-caller-pattern rename-file (form form) :lisp)
+(define-caller-pattern delete-file (form) :lisp)
+(define-caller-pattern probe-file (form) :lisp)
+(define-caller-pattern file-write-date (form) :lisp)
+(define-caller-pattern file-author (form) :lisp)
+(define-caller-pattern file-position (form (:optional form)) :lisp)
+(define-caller-pattern file-length (form) :lisp)
+(define-caller-pattern file-string-length (form form) :lisp2)
+(define-caller-pattern load (form &key (:star form)) :lisp)
+(define-variable-pattern *load-verbose* :lisp)
+(define-variable-pattern *load-print* :lisp2)
+(define-variable-pattern *load-pathname* :lisp2)
+(define-variable-pattern *load-truename* :lisp2)
+(define-caller-pattern make-load-form (form) :lisp2)
+(define-caller-pattern make-load-form-saving-slots (form &optional form)
+ :lisp2)
+(define-caller-pattern directory (form &key (:star form)) :lisp)
+
+;;; Errors
+(define-caller-pattern error (form (:star form)) :lisp)
+(define-caller-pattern cerror (form form (:star form)) :lisp)
+(define-caller-pattern warn (form (:star form)) :lisp)
+(define-variable-pattern *break-on-warnings* :lisp)
+(define-caller-pattern break (&optional form (:star form)) :lisp)
+(define-caller-pattern check-type (form form (:optional form)) :lisp)
+(define-caller-pattern assert
+ (form
+ (:optional ((:star var))
+ (:optional form (:star form))))
+ :lisp)
+(define-caller-pattern etypecase (form (:star (symbol (:star form)))) :lisp)
+(define-caller-pattern ctypecase (form (:star (symbol (:star form)))) :lisp)
+(define-caller-pattern ecase
+ (form
+ (:star ((:or symbol ((:star symbol)))
+ (:star form))))
+ :lisp)
+(define-caller-pattern ccase
+ (form
+ (:star ((:or symbol ((:star symbol)))
+ (:star form))))
+ :lisp)
+
+;;; The Compiler
+(define-caller-pattern compile (form (:optional form)) :lisp)
+(define-caller-pattern compile-file (form &key (:star form)) :lisp)
+(define-variable-pattern *compile-verbose* :lisp2)
+(define-variable-pattern *compile-print* :lisp2)
+(define-variable-pattern *compile-file-pathname* :lisp2)
+(define-variable-pattern *compile-file-truename* :lisp2)
+(define-caller-pattern load-time-value (form (:optional form)) :lisp2)
+(define-caller-pattern disassemble (form) :lisp)
+(define-caller-pattern function-lambda-expression (fn) :lisp2)
+(define-caller-pattern with-compilation-unit (((:star :ignore)) (:star form))
+ :lisp2)
+
+;;; Documentation
+(define-caller-pattern documentation (form form) :lisp)
+(define-caller-pattern trace ((:star form)) :lisp)
+(define-caller-pattern untrace ((:star form)) :lisp)
+(define-caller-pattern step (form) :lisp)
+(define-caller-pattern time (form) :lisp)
+(define-caller-pattern describe (form &optional form) :lisp)
+(define-caller-pattern describe-object (form &optional form) :lisp2)
+(define-caller-pattern inspect (form) :lisp)
+(define-caller-pattern room ((:optional form)) :lisp)
+(define-caller-pattern ed ((:optional form)) :lisp)
+(define-caller-pattern dribble ((:optional form)) :lisp)
+(define-caller-pattern apropos (form (:optional form)) :lisp)
+(define-caller-pattern apropos-list (form (:optional form)) :lisp)
+(define-caller-pattern get-decoded-time () :lisp)
+(define-caller-pattern get-universal-time () :lisp)
+(define-caller-pattern decode-universal-time (form &optional form) :lisp)
+(define-caller-pattern encode-universal-time
+ (form form form form form form &optional form) :lisp)
+(define-caller-pattern get-internal-run-time () :lisp)
+(define-caller-pattern get-internal-real-time () :lisp)
+(define-caller-pattern sleep (form) :lisp)
+
+(define-caller-pattern lisp-implementation-type () :lisp)
+(define-caller-pattern lisp-implementation-version () :lisp)
+(define-caller-pattern machine-type () :lisp)
+(define-caller-pattern machine-version () :lisp)
+(define-caller-pattern machine-instance () :lisp)
+(define-caller-pattern software-type () :lisp)
+(define-caller-pattern software-version () :lisp)
+(define-caller-pattern short-site-name () :lisp)
+(define-caller-pattern long-site-name () :lisp)
+(define-variable-pattern *features* :lisp)
+
+(define-caller-pattern identity (form) :lisp)
+
+;;; Pretty Printing
+(define-variable-pattern *print-pprint-dispatch* :lisp2)
+(define-variable-pattern *print-right-margin* :lisp2)
+(define-variable-pattern *print-miser-width* :lisp2)
+(define-variable-pattern *print-lines* :lisp2)
+(define-caller-pattern pprint-newline (form &optional form) :lisp2)
+(define-caller-pattern pprint-logical-block
+ ((var form &key (:star form))
+ (:star form))
+ :lisp2)
+(define-caller-pattern pprint-exit-if-list-exhausted () :lisp2)
+(define-caller-pattern pprint-pop () :lisp2)
+(define-caller-pattern pprint-indent (form form &optional form) :lisp2)
+(define-caller-pattern pprint-tab (form form form &optional form) :lisp2)
+(define-caller-pattern pprint-fill (form form &optional form form) :lisp2)
+(define-caller-pattern pprint-linear (form form &optional form form) :lisp2)
+(define-caller-pattern pprint-tabular (form form &optional form form form)
+ :lisp2)
+(define-caller-pattern formatter (control-string) :lisp2)
+(define-caller-pattern copy-pprint-dispatch (&optional form) :lisp2)
+(define-caller-pattern pprint-dispatch (form &optional form) :lisp2)
+(define-caller-pattern set-pprint-dispatch (form form &optional form form)
+ :lisp2)
+
+;;; CLOS
+(define-caller-pattern add-method (fn form) :lisp2)
+(define-caller-pattern call-method (form form) :lisp2)
+(define-caller-pattern call-next-method ((:star form)) :lisp2)
+(define-caller-pattern change-class (form form) :lisp2)
+(define-caller-pattern class-name (form) :lisp2)
+(define-caller-pattern class-of (form) :lisp2)
+(define-caller-pattern compute-applicable-methods (fn (:star form)) :lisp2)
+(define-caller-pattern defclass (name &rest :ignore) :lisp2)
+(define-caller-pattern defgeneric (name lambda-list &rest :ignore) :lisp2)
+(define-caller-pattern define-method-combination
+ (name lambda-list ((:star :ignore))
+ (:optional ((:eq :arguments) :ignore))
+ (:optional ((:eq :generic-function) :ignore))
+ (:star (:or declaration documentation-string))
+ (:star form))
+ :lisp2)
+(define-caller-pattern defmethod
+ (name (:star symbol) lambda-list
+ (:star (:or declaration documentation-string))
+ (:star form))
+ :lisp2)
+(define-caller-pattern ensure-generic-function (name &key (:star form)) :lisp2)
+(define-caller-pattern find-class (form &optional form form) :lisp2)
+(define-caller-pattern find-method (fn &rest :ignore) :lisp2)
+(define-caller-pattern function-keywords (&rest :ignore) :lisp2)
+(define-caller-pattern generic-flet (((:star (name lambda-list))) (:star form))
+ :lisp2)
+(define-caller-pattern generic-labels
+ (((:star (name lambda-list))) (:star form))
+ :lisp2)
+(define-caller-pattern generic-function (lambda-list) :lisp2)
+(define-caller-pattern initialize-instance (form &key (:star form)) :lisp2)
+(define-caller-pattern invalid-method-error (fn form (:star form)) :lisp2)
+(define-caller-pattern make-instance (fn (:star form)) :lisp2)
+(define-caller-pattern make-instances-obsolete (fn) :lisp2)
+(define-caller-pattern method-combination-error (form (:star form)) :lisp2)
+(define-caller-pattern method-qualifiers (fn) :lisp2)
+(define-caller-pattern next-method-p () :lisp2)
+(define-caller-pattern no-applicable-method (fn (:star form)) :lisp2)
+(define-caller-pattern no-next-method (fn (:star form)) :lisp2)
+(define-caller-pattern print-object (form form) :lisp2)
+(define-caller-pattern reinitialize-instance (form (:star form)) :lisp2)
+(define-caller-pattern remove-method (fn form) :lisp2)
+(define-caller-pattern shared-initialize (form form (:star form)) :lisp2)
+(define-caller-pattern slot-boundp (form form) :lisp2)
+(define-caller-pattern slot-exists-p (form form) :lisp2)
+(define-caller-pattern slot-makeunbound (form form) :lisp2)
+(define-caller-pattern slot-missing (fn form form form &optional form) :lisp2)
+(define-caller-pattern slot-unbound (fn form form) :lisp2)
+(define-caller-pattern slot-value (form form) :lisp2)
+(define-caller-pattern update-instance-for-different-class
+ (form form (:star form)) :lisp2)
+(define-caller-pattern update-instance-for-redefined-class
+ (form form (:star form)) :lisp2)
+(define-caller-pattern with-accessors
+ (((:star :ignore)) form
+ (:star declaration)
+ (:star form))
+ :lisp2)
+(define-caller-pattern with-added-methods
+ ((name lambda-list) form
+ (:star form))
+ :lisp2)
+(define-caller-pattern with-slots
+ (((:star :ignore)) form
+ (:star declaration)
+ (:star form))
+ :lisp2)
+
+;;; Conditions
+(define-caller-pattern signal (form (:star form)) :lisp2)
+(define-variable-pattern *break-on-signals* :lisp2)
+(define-caller-pattern handler-case (form (:star (form ((:optional var))
+ (:star form))))
+ :lisp2)
+(define-caller-pattern ignore-errors ((:star form)) :lisp2)
+(define-caller-pattern handler-bind (((:star (form form)))
+ (:star form))
+ :lisp2)
+(define-caller-pattern define-condition (name &rest :ignore) :lisp2)
+(define-caller-pattern make-condition (form &rest :ignore) :lisp2)
+(define-caller-pattern with-simple-restart
+ ((name form (:star form)) (:star form)) :lisp2)
+(define-caller-pattern restart-case
+ (form
+ (:star (form form (:star form))))
+ :lisp2)
+(define-caller-pattern restart-bind
+ (((:star (name fn &key (:star form))))
+ (:star form))
+ :lisp2)
+(define-caller-pattern with-condition-restarts
+ (form form
+ (:star declaration)
+ (:star form))
+ :lisp2)
+(define-caller-pattern compute-restarts (&optional form) :lisp2)
+(define-caller-pattern restart-name (form) :lisp2)
+(define-caller-pattern find-restart (form &optional form) :lisp2)
+(define-caller-pattern invoke-restart (form (:star form)) :lisp2)
+(define-caller-pattern invoke-restart-interactively (form) :lisp2)
+(define-caller-pattern abort (&optional form) :lisp2)
+(define-caller-pattern continue (&optional form) :lisp2)
+(define-caller-pattern muffle-warning (&optional form) :lisp2)
+(define-caller-pattern store-value (form &optional form) :lisp2)
+(define-caller-pattern use-value (form &optional form) :lisp2)
+(define-caller-pattern invoke-debugger (form) :lisp2)
+(define-variable-pattern *debugger-hook* :lisp2)
+(define-caller-pattern simple-condition-format-string (form) :lisp2)
+(define-caller-pattern simple-condition-format-arguments (form) :lisp2)
+(define-caller-pattern type-error-datum (form) :lisp2)
+(define-caller-pattern type-error-expected-type (form) :lisp2)
+(define-caller-pattern package-error-package (form) :lisp2)
+(define-caller-pattern stream-error-stream (form) :lisp2)
+(define-caller-pattern file-error-pathname (form) :lisp2)
+(define-caller-pattern cell-error-name (form) :lisp2)
+(define-caller-pattern arithmetic-error-operation (form) :lisp2)
+(define-caller-pattern arithmetic-error-operands (form) :lisp2)
+
+;;; For ZetaLisp Flavors
+(define-caller-pattern send (form fn (:star form)) :flavors)