Much maturering of vim configs

18 files changed, 16525 insertions, 0 deletions

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)))))