Add support for Scheme and Racket language.

sources_non_forked/slimv/slime/contrib/README.md

@@ -0,0 +1,14 @@
+This directory contains source code which may be useful to some Slime
+users.  `*.el` files are Emacs Lisp source and `*.lisp` files contain
+Common Lisp source code.  If not otherwise stated in the file itself,
+the files are placed in the Public Domain.
+
+The components in this directory are more or less detached from the
+rest of Slime.  They are essentially "add-ons".  But Slime can also be
+used without them.  The code is maintained by the respective authors.
+
+See the top level README.md for how to use packages in this directory.
+
+Finally, the contrib `slime-fancy` is specially noteworthy, as it
+represents a meta-contrib that'll load a bunch of commonly used
+contribs. Look into `slime-fancy.el` to find out which.

sources_non_forked/slimv/slime/contrib/swank-asdf.lisp

@@ -0,0 +1,533 @@
+;;; swank-asdf.lisp -- ASDF support
+;;
+;; Authors: Daniel Barlow <dan@telent.net>
+;;          Marco Baringer <mb@bese.it>
+;;          Edi Weitz <edi@agharta.de>
+;;          Francois-Rene Rideau <tunes@google.com>
+;;          and others
+;; License: Public Domain
+;;
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+;;; The best way to load ASDF is from an init file of an
+;;; implementation.  If ASDF is not loaded at the time swank-asdf is
+;;; loaded, it will be tried first with (require "asdf"), if that
+;;; doesn't help and *asdf-path* is set, it will be loaded from that
+;;; file.
+;;; To set *asdf-path* put the following into ~/.swank.lisp:
+;;; (defparameter swank::*asdf-path* #p"/path/to/asdf/asdf.lisp")
+  (defvar *asdf-path* nil
+    "Path to asdf.lisp file, to be loaded in case (require \"asdf\") fails."))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (member :asdf *features*)
+    (ignore-errors (funcall 'require "asdf"))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (member :asdf *features*)
+    (handler-bind ((warning #'muffle-warning))
+      (when *asdf-path*
+        (load *asdf-path* :if-does-not-exist nil)))))
+
+;; If still not found, error out.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (member :asdf *features*)
+    (error "Could not load ASDF.
+Please update your implementation or
+install a recent release of ASDF and in your ~~/.swank.lisp specify:
+ (defparameter swank::*asdf-path* #p\"/path/containing/asdf/asdf.lisp\")")))
+
+;;; If ASDF is too old, punt.
+;; As of January 2014, Quicklisp has been providing 2.26 for a year
+;; (and previously had 2.014.6 for over a year), whereas
+;; all SLIME-supported implementations provide ASDF3 (i.e. 2.27 or later)
+;; except LispWorks (stuck with 2.019) and SCL (which hasn't been released
+;; in years and doesn't provide ASDF at all, but is fully supported by ASDF).
+;; If your implementation doesn't provide ASDF, or provides an old one,
+;; install an upgrade yourself and configure *asdf-path*.
+;; It's just not worth the hassle supporting something
+;; that doesn't even have COERCE-PATHNAME.
+;;
+;; NB: this version check is duplicated in swank-loader.lisp so that we don't
+;; try to load this contrib when ASDF is too old since that will abort the SLIME
+;; connection.
+#-asdf3
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (and #+asdf2 (asdf:version-satisfies (asdf:asdf-version) "2.14.6"))
+    (error "Your ASDF is too old. ~
+            The oldest version supported by swank-asdf is 2.014.6.")))
+;;; Import functionality from ASDF that isn't available in all ASDF versions.
+;;; Please do NOT depend on any of the below as reference:
+;;; they are sometimes stripped down versions, for compatibility only.
+;;; Indeed, they are supposed to work on *OLDER*, not *NEWER* versions of ASDF.
+;;;
+;;; The way I got these is usually by looking at the current definition,
+;;; using git blame in one screen to locate which commit last modified it,
+;;; and git log in another to determine which release that made it in.
+;;; It is OK for some of the below definitions to be or become obsolete,
+;;; as long as it will make do with versions older than the tagged version:
+;;; if ASDF is more recent, its more recent version will win.
+;;;
+;;; If your software is hacking ASDF, use its internals.
+;;; If you want ASDF utilities in user software, please use ASDF-UTILS.
+
+(defun asdf-at-least (version)
+  (asdf:version-satisfies (asdf:asdf-version) version))
+
+(defmacro asdefs (version &rest defs)
+  (flet ((defun* (version name aname rest)
+           `(progn
+              (defun ,name ,@rest)
+              (declaim (notinline ,name))
+              (when (asdf-at-least ,version)
+                (setf (fdefinition ',name) (fdefinition ',aname)))))
+         (defmethod* (version aname rest)
+           `(unless (asdf-at-least ,version)
+              (defmethod ,aname ,@rest)))
+         (defvar* (name aname rest)
+           `(progn
+              (define-symbol-macro ,name ,aname)
+              (defvar ,aname ,@rest))))
+    `(progn
+       ,@(loop :for (def name . args) :in defs
+               :for aname = (intern (string name) :asdf)
+               :collect
+               (ecase def
+                 ((defun) (defun* version name aname args))
+                 ((defmethod) (defmethod* version aname args))
+                 ((defvar) (defvar* name aname args)))))))
+
+(asdefs "2.15"
+ (defvar *wild* #-cormanlisp :wild #+cormanlisp "*")
+
+ (defun collect-asds-in-directory (directory collect)
+   (map () collect (directory-asd-files directory)))
+
+ (defun register-asd-directory (directory &key recurse exclude collect)
+   (if (not recurse)
+       (collect-asds-in-directory directory collect)
+       (collect-sub*directories-asd-files
+        directory :exclude exclude :collect collect))))
+
+(asdefs "2.16"
+ (defun load-sysdef (name pathname)
+   (declare (ignore name))
+   (let ((package (asdf::make-temporary-package)))
+     (unwind-protect
+          (let ((*package* package)
+                (*default-pathname-defaults*
+                  (asdf::pathname-directory-pathname
+                   (translate-logical-pathname pathname))))
+            (asdf::asdf-message
+             "~&; Loading system definition from ~A into ~A~%" ;
+             pathname package)
+            (load pathname))
+     (delete-package package))))
+
+ (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
+   (apply 'directory pathname-spec
+          (append keys
+                  '#.(or #+allegro
+                         '(:directories-are-files nil
+                           :follow-symbolic-links nil)
+                         #+clozure
+                         '(:follow-links nil)
+                         #+clisp
+                         '(:circle t :if-does-not-exist :ignore)
+                         #+(or cmu scl)
+                         '(:follow-links nil :truenamep nil)
+                         #+sbcl
+                         (when (find-symbol "RESOLVE-SYMLINKS" '#:sb-impl)
+                           '(:resolve-symlinks nil)))))))
+(asdefs "2.17"
+ (defun collect-sub*directories-asd-files
+     (directory &key
+                (exclude asdf::*default-source-registry-exclusions*)
+                collect)
+   (asdf::collect-sub*directories
+    directory
+    (constantly t)
+    (lambda (x) (not (member (car (last (pathname-directory x)))
+                             exclude :test #'equal)))
+    (lambda (dir) (collect-asds-in-directory dir collect))))
+
+ (defun system-source-directory (system-designator)
+   (asdf::pathname-directory-pathname
+    (asdf::system-source-file system-designator)))
+
+ (defun filter-logical-directory-results (directory entries merger)
+   (if (typep directory 'logical-pathname)
+       (loop for f in entries
+             when
+             (if (typep f 'logical-pathname)
+                 f
+                 (let ((u (ignore-errors (funcall merger f))))
+                   (and u
+                        (equal (ignore-errors (truename u))
+                               (truename f))
+                        u)))
+             collect it)
+       entries))
+
+ (defun directory-asd-files (directory)
+   (directory-files directory asdf::*wild-asd*)))
+
+(asdefs "2.19"
+    (defun subdirectories (directory)
+      (let* ((directory (asdf::ensure-directory-pathname directory))
+             #-(or abcl cormanlisp xcl)
+             (wild (asdf::merge-pathnames*
+                    #-(or abcl allegro cmu lispworks sbcl scl xcl)
+                    asdf::*wild-directory*
+                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
+                directory))
+             (dirs
+               #-(or abcl cormanlisp xcl)
+               (ignore-errors
+                (directory* wild . #.(or #+clozure '(:directories t :files nil)
+                                         #+mcl '(:directories t))))
+               #+(or abcl xcl) (system:list-directory directory)
+               #+cormanlisp (cl::directory-subdirs directory))
+             #+(or abcl allegro cmu lispworks sbcl scl xcl)
+             (dirs (loop for x in dirs
+                         for d = #+(or abcl xcl) (extensions:probe-directory x)
+                         #+allegro (excl:probe-directory x)
+                         #+(or cmu sbcl scl) (asdf::directory-pathname-p x)
+                         #+lispworks (lw:file-directory-p x)
+                         when d collect #+(or abcl allegro xcl) d
+                         #+(or cmu lispworks sbcl scl) x)))
+        (filter-logical-directory-results
+         directory dirs
+         (let ((prefix (or (normalize-pathname-directory-component
+                            (pathname-directory directory))
+                           ;; because allegro 8.x returns NIL for #p"FOO:"
+                           '(:absolute))))
+           (lambda (d)
+             (let ((dir (normalize-pathname-directory-component
+                         (pathname-directory d))))
+               (and (consp dir) (consp (cdr dir))
+                    (make-pathname
+                     :defaults directory :name nil :type nil :version nil
+                     :directory
+                     (append prefix
+                             (make-pathname-component-logical
+                              (last dir))))))))))))
+
+(asdefs "2.21"
+ (defun component-loaded-p (c)
+   (and (gethash 'load-op (asdf::component-operation-times
+                           (asdf::find-component c nil))) t))
+
+ (defun normalize-pathname-directory-component (directory)
+   (cond
+     #-(or cmu sbcl scl)
+     ((stringp directory) `(:absolute ,directory) directory)
+     ((or (null directory)
+          (and (consp directory)
+               (member (first directory) '(:absolute :relative))))
+      directory)
+     (t
+      (error "Unrecognized pathname directory component ~S" directory))))
+
+ (defun make-pathname-component-logical (x)
+   (typecase x
+     ((eql :unspecific) nil)
+     #+clisp (string (string-upcase x))
+     #+clisp (cons (mapcar 'make-pathname-component-logical x))
+     (t x)))
+
+ (defun make-pathname-logical (pathname host)
+   (make-pathname
+    :host host
+    :directory (make-pathname-component-logical (pathname-directory pathname))
+    :name (make-pathname-component-logical (pathname-name pathname))
+    :type (make-pathname-component-logical (pathname-type pathname))
+    :version (make-pathname-component-logical (pathname-version pathname)))))
+
+(asdefs "2.22"
+ (defun directory-files (directory &optional (pattern asdf::*wild-file*))
+   (let ((dir (pathname directory)))
+     (when (typep dir 'logical-pathname)
+       (when (wild-pathname-p dir)
+         (error "Invalid wild pattern in logical directory ~S" directory))
+       (unless (member (pathname-directory pattern)
+                       '(() (:relative)) :test 'equal)
+         (error "Invalid file pattern ~S for logical directory ~S"
+                pattern directory))
+       (setf pattern (make-pathname-logical pattern (pathname-host dir))))
+     (let ((entries (ignore-errors
+                     (directory* (asdf::merge-pathnames* pattern dir)))))
+       (filter-logical-directory-results
+        directory entries
+        (lambda (f)
+          (make-pathname :defaults dir
+                         :name (make-pathname-component-logical
+                                (pathname-name f))
+                         :type (make-pathname-component-logical
+                                (pathname-type f))
+                         :version (make-pathname-component-logical
+                                   (pathname-version f)))))))))
+
+(asdefs "2.26.149"
+ (defmethod component-relative-pathname ((system asdf:system))
+   (asdf::coerce-pathname
+    (and (slot-boundp system 'asdf::relative-pathname)
+         (slot-value system 'asdf::relative-pathname))
+    :type :directory
+    :defaults (system-source-directory system)))
+ (defun load-asd (pathname &key name &allow-other-keys)
+   (asdf::load-sysdef (or name (string-downcase (pathname-name pathname)))
+                      pathname)))
+
+
+;;; Taken from ASDF 1.628
+(defmacro while-collecting ((&rest collectors) &body body)
+  `(asdf::while-collecting ,collectors ,@body))
+
+;;; Now for SLIME-specific stuff
+
+(defun asdf-operation (operation)
+  (or (asdf::find-symbol* operation :asdf)
+      (error "Couldn't find ASDF operation ~S" operation)))
+
+(defun map-system-components (fn system)
+  (map-component-subcomponents fn (asdf:find-system system)))
+
+(defun map-component-subcomponents (fn component)
+  (when component
+    (funcall fn component)
+    (when (typep component 'asdf:module)
+      (dolist (c (asdf:module-components component))
+        (map-component-subcomponents fn c)))))
+
+;;; Maintaining a pathname to component table
+
+(defvar *pathname-component* (make-hash-table :test 'equal))
+
+(defun clear-pathname-component-table ()
+  (clrhash *pathname-component*))
+
+(defun register-system-pathnames (system)
+  (map-system-components 'register-component-pathname system))
+
+(defun recompute-pathname-component-table ()
+  (clear-pathname-component-table)
+  (asdf::map-systems 'register-system-pathnames))
+
+(defun pathname-component (x)
+  (gethash (pathname x) *pathname-component*))
+
+(defmethod asdf:component-pathname :around ((component asdf:component))
+  (let ((p (call-next-method)))
+    (when (pathnamep p)
+      (setf (gethash p *pathname-component*) component))
+    p))
+
+(defun register-component-pathname (component)
+  (asdf:component-pathname component))
+
+(recompute-pathname-component-table)
+
+;;; This is a crude hack, see ASDF's LP #481187.
+(defslimefun who-depends-on (system)
+  (flet ((system-dependencies (op system)
+           (mapcar (lambda (dep)
+                     (asdf::coerce-name (if (consp dep) (second dep) dep)))
+                   (cdr (assoc op (asdf:component-depends-on op system))))))
+    (let ((system-name (asdf::coerce-name system))
+          (result))
+      (asdf::map-systems
+       (lambda (system)
+         (when (member system-name
+                       (system-dependencies 'asdf:load-op system)
+                       :test #'string=)
+           (push (asdf:component-name system) result))))
+      result)))
+
+(defmethod xref-doit ((type (eql :depends-on)) thing)
+  (when (typep thing '(or string symbol))
+    (loop for dependency in (who-depends-on thing)
+          for asd-file = (asdf:system-definition-pathname dependency)
+          when asd-file
+          collect (list dependency
+                        (swank/backend:make-location
+                         `(:file ,(namestring asd-file))
+                         `(:position 1)
+                         `(:snippet ,(format nil "(defsystem :~A" dependency)
+                           :align t))))))
+
+(defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
+  "Compile and load SYSTEM using ASDF.
+Record compiler notes signalled as `compiler-condition's."
+  (collect-notes
+   (lambda ()
+     (apply #'operate-on-system system-name operation keywords))))
+
+(defun operate-on-system (system-name operation-name &rest keyword-args)
+  "Perform OPERATION-NAME on SYSTEM-NAME using ASDF.
+The KEYWORD-ARGS are passed on to the operation.
+Example:
+\(operate-on-system \"cl-ppcre\" 'compile-op :force t)"
+  (handler-case
+      (with-compilation-hooks ()
+        (apply #'asdf:operate (asdf-operation operation-name)
+               system-name keyword-args)
+        t)
+    ((or asdf:compile-error #+asdf3 asdf/lisp-build:compile-file-error)
+      () nil)))
+
+(defun unique-string-list (&rest lists)
+  (sort (delete-duplicates (apply #'append lists) :test #'string=) #'string<))
+
+(defslimefun list-all-systems-in-central-registry ()
+  "Returns a list of all systems in ASDF's central registry
+AND in its source-registry. (legacy name)"
+  (unique-string-list
+   (mapcar
+    #'pathname-name
+    (while-collecting (c)
+      (loop for dir in asdf:*central-registry*
+            for defaults = (eval dir)
+            when defaults
+            do (collect-asds-in-directory defaults #'c))
+      (asdf:ensure-source-registry)
+      (if (or #+asdf3 t
+	      #-asdf3 (asdf:version-satisfies (asdf:asdf-version) "2.15"))
+          (loop :for k :being :the :hash-keys :of asdf::*source-registry*
+		:do (c k))
+	  #-asdf3
+          (dolist (entry (asdf::flatten-source-registry))
+            (destructuring-bind (directory &key recurse exclude) entry
+              (register-asd-directory
+               directory
+               :recurse recurse :exclude exclude :collect #'c))))))))
+
+(defslimefun list-all-systems-known-to-asdf ()
+  "Returns a list of all systems ASDF knows already."
+  (while-collecting (c)
+    (asdf::map-systems (lambda (system) (c (asdf:component-name system))))))
+
+(defslimefun list-asdf-systems ()
+  "Returns the systems in ASDF's central registry and those which ASDF
+already knows."
+  (unique-string-list
+   (list-all-systems-known-to-asdf)
+   (list-all-systems-in-central-registry)))
+
+(defun asdf-component-source-files (component)
+  (while-collecting (c)
+    (labels ((f (x)
+               (typecase x
+                 (asdf:source-file (c (asdf:component-pathname x)))
+                 (asdf:module (map () #'f (asdf:module-components x))))))
+      (f component))))
+
+(defun make-operation (x)
+  #+#.(swank/backend:with-symbol 'make-operation 'asdf)
+  (asdf:make-operation x)
+  #-#.(swank/backend:with-symbol 'make-operation 'asdf)
+  (make-instance x))
+
+(defun asdf-component-output-files (component)
+  (while-collecting (c)
+    (labels ((f (x)
+               (typecase x
+                 (asdf:source-file
+                  (map () #'c
+                       (asdf:output-files (make-operation 'asdf:compile-op) x)))
+                 (asdf:module (map () #'f (asdf:module-components x))))))
+      (f component))))
+
+(defslimefun asdf-system-files (name)
+  (let* ((system (asdf:find-system name))
+         (files (mapcar #'namestring
+                        (cons
+                         (asdf:system-definition-pathname system)
+                         (asdf-component-source-files system))))
+         (main-file (find name files
+                          :test #'equalp :key #'pathname-name :start 1)))
+    (if main-file
+        (cons main-file (remove main-file files
+                                :test #'equal :count 1))
+        files)))
+
+(defslimefun asdf-system-loaded-p (name)
+  (component-loaded-p name))
+
+(defslimefun asdf-system-directory (name)
+  (namestring (translate-logical-pathname (asdf:system-source-directory name))))
+
+(defun pathname-system (pathname)
+  (let ((component (pathname-component pathname)))
+    (when component
+      (asdf:component-name (asdf:component-system component)))))
+
+(defslimefun asdf-determine-system (file buffer-package-name)
+  (or
+   (and file
+        (pathname-system file))
+   (and file
+        (progn
+          ;; If not found, let's rebuild the table first
+          (recompute-pathname-component-table)
+          (pathname-system file)))
+   ;; If we couldn't find an already defined system,
+   ;; try finding a system that's named like BUFFER-PACKAGE-NAME.
+   (loop with package = (guess-buffer-package buffer-package-name)
+         for name in (package-names package)
+         for system = (asdf:find-system (asdf::coerce-name name) nil)
+         when (and system
+                   (or (not file)
+                       (pathname-system file)))
+         return (asdf:component-name system))))
+
+(defslimefun delete-system-fasls (name)
+  (let ((removed-count
+         (loop for file in (asdf-component-output-files
+                            (asdf:find-system name))
+               when (probe-file file)
+               count it
+               and
+               do (delete-file file))))
+    (format nil "~d file~:p ~:*~[were~;was~:;were~] removed" removed-count)))
+
+(defvar *recompile-system* nil)
+
+(defmethod asdf:operation-done-p :around
+    ((operation asdf:compile-op)
+     component)
+    (unless (eql *recompile-system*
+                 (asdf:component-system component))
+      (call-next-method)))
+
+(defslimefun reload-system (name)
+  (let ((*recompile-system* (asdf:find-system name)))
+    (operate-on-system-for-emacs name 'asdf:load-op)))
+
+;;; Hook for compile-file-for-emacs
+
+(defun try-compile-file-with-asdf (pathname load-p &rest options)
+  (declare (ignore options))
+  (let ((component (pathname-component pathname)))
+    (when component
+      ;;(format t "~&Compiling ASDF component ~S~%" component)
+      (let ((op (make-operation 'asdf:compile-op)))
+        (with-compilation-hooks ()
+          (asdf:perform op component))
+        (when load-p
+          (asdf:perform (make-operation 'asdf:load-op) component))
+        (values t t nil (first (asdf:output-files op component)))))))
+
+(defun try-compile-asd-file (pathname load-p &rest options)
+  (declare (ignore load-p options))
+  (when (equalp (pathname-type pathname) "asd")
+    (load-asd pathname)
+    (values t t nil pathname)))
+
+(pushnew 'try-compile-asd-file *compile-file-for-emacs-hook*)
+
+;;; (pushnew 'try-compile-file-with-asdf *compile-file-for-emacs-hook*)
+
+(provide :swank-asdf)

sources_non_forked/slimv/slime/contrib/swank-buffer-streams.lisp

@@ -0,0 +1,39 @@
+;;; swank-buffer-streams.lisp --- Streams that output to a buffer
+;;;
+;;; Authors: Ed Langley  <el-github@elangley.org>
+;;;
+;;; License: This code has been placed in the Public Domain.  All warranties
+;;;          are disclaimed.
+
+(in-package :swank)
+
+(defpackage :swank-buffer-streams
+  (:use :cl)
+  (:import-from :swank
+                defslimefun
+                add-hook
+                encode-message
+                send-event
+                find-thread
+                dcase
+                current-socket-io
+                send-to-emacs
+                current-thread-id
+                wait-for-event
+
+                *emacs-connection*
+                *event-hook*)
+  (:export make-buffer-output-stream))
+
+(in-package :swank-buffer-streams)
+
+(defun get-temporary-identifier ()
+  (intern (symbol-name (gensym "BUFFER"))
+          :keyword))
+
+(defun make-buffer-output-stream (&optional (target-identifier (get-temporary-identifier)))
+  (swank:ed-rpc '#:slime-make-buffer-stream-target (current-thread-id) target-identifier)
+  (values (swank:make-output-stream-for-target *emacs-connection* target-identifier)
+          target-identifier))
+
+(provide :swank-buffer-streams)

sources_non_forked/slimv/slime/contrib/swank-c-p-c.lisp

@@ -0,0 +1,298 @@
+;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion
+;;
+;; Author: Luke Gorrie  <luke@synap.se>
+;;         Edi Weitz  <edi@agharta.de>
+;;         Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de> 
+;;         Tobias C. Rittweiler <tcr@freebits.de>
+;;         and others
+;;
+;; License: Public Domain
+;;
+
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (swank-require :swank-util))
+
+(defslimefun completions (string default-package-name)
+  "Return a list of completions for a symbol designator STRING.  
+
+The result is the list (COMPLETION-SET COMPLETED-PREFIX), where
+COMPLETION-SET is the list of all matching completions, and
+COMPLETED-PREFIX is the best (partial) completion of the input
+string.
+
+Simple compound matching is supported on a per-hyphen basis:
+
+  (completions \"m-v-\" \"COMMON-LISP\")
+    ==> ((\"multiple-value-bind\" \"multiple-value-call\" 
+          \"multiple-value-list\" \"multiple-value-prog1\" 
+          \"multiple-value-setq\" \"multiple-values-limit\")
+         \"multiple-value\")
+
+\(For more advanced compound matching, see FUZZY-COMPLETIONS.)
+
+If STRING is package qualified the result list will also be
+qualified.  If string is non-qualified the result strings are
+also not qualified and are considered relative to
+DEFAULT-PACKAGE-NAME.
+
+The way symbols are matched depends on the symbol designator's
+format. The cases are as follows:
+  FOO      - Symbols with matching prefix and accessible in the buffer package.
+  PKG:FOO  - Symbols with matching prefix and external in package PKG.
+  PKG::FOO - Symbols with matching prefix and accessible in package PKG.
+"
+  (multiple-value-bind (name package-name package internal-p)
+      (parse-completion-arguments string default-package-name)
+    (let* ((symbol-set  (symbol-completion-set 
+			 name package-name package internal-p
+			 (make-compound-prefix-matcher #\-)))
+	   (package-set (package-completion-set 
+			 name package-name package internal-p
+			 (make-compound-prefix-matcher '(#\. #\-))))
+	   (completion-set
+	    (format-completion-set (nconc symbol-set package-set) 
+				   internal-p package-name)))
+      (when completion-set
+	(list completion-set (longest-compound-prefix completion-set))))))
+
+
+;;;;; Find completion set
+
+(defun symbol-completion-set (name package-name package internal-p matchp)
+  "Return the set of completion-candidates as strings."
+  (mapcar (completion-output-symbol-converter name)
+	  (and package
+	       (mapcar #'symbol-name
+		       (find-matching-symbols name
+					      package
+					      (and (not internal-p)
+						   package-name)
+					      matchp)))))
+
+(defun package-completion-set (name package-name package internal-p matchp)
+  (declare (ignore package internal-p))
+  (mapcar (completion-output-package-converter name)
+	  (and (not package-name)
+	       (find-matching-packages name matchp))))
+
+(defun find-matching-symbols (string package external test)
+  "Return a list of symbols in PACKAGE matching STRING.
+TEST is called with two strings.  If EXTERNAL is true, only external
+symbols are returned."
+  (let ((completions '())
+        (converter (completion-output-symbol-converter string)))
+    (flet ((symbol-matches-p (symbol)
+             (and (or (not external)
+                      (symbol-external-p symbol package))
+                  (funcall test string
+                           (funcall converter (symbol-name symbol))))))
+      (do-symbols* (symbol package) 
+        (when (symbol-matches-p symbol)
+          (push symbol completions))))
+    completions))
+
+(defun find-matching-symbols-in-list (string list test)
+  "Return a list of symbols in LIST matching STRING.
+TEST is called with two strings."
+  (let ((completions '())
+        (converter (completion-output-symbol-converter string)))
+    (flet ((symbol-matches-p (symbol)
+             (funcall test string
+                      (funcall converter (symbol-name symbol)))))
+      (dolist (symbol list) 
+        (when (symbol-matches-p symbol)
+          (push symbol completions))))
+    (remove-duplicates completions)))
+
+(defun find-matching-packages (name matcher)
+  "Return a list of package names matching NAME with MATCHER.
+MATCHER is a two-argument predicate."
+  (let ((converter (completion-output-package-converter name)))
+    (remove-if-not (lambda (x)
+                     (funcall matcher name (funcall converter x)))
+                   (mapcar (lambda (pkgname)
+                             (concatenate 'string pkgname ":"))
+                           (loop for package in (list-all-packages)
+                                 nconcing (package-names package))))))
+
+
+;; PARSE-COMPLETION-ARGUMENTS return table:
+;; 
+;;  user behaviour |  NAME  | PACKAGE-NAME | PACKAGE 
+;; ----------------+--------+--------------+-----------------------------------
+;; asdf     [tab]  | "asdf" |     NIL      | #<PACKAGE "DEFAULT-PACKAGE-NAME">
+;;                 |        |              |      or *BUFFER-PACKAGE*
+;; asdf:    [tab]  |   ""   |    "asdf"    | #<PACKAGE "ASDF">
+;;                 |        |              |
+;; asdf:foo [tab]  | "foo"  |    "asdf"    | #<PACKAGE "ASDF">
+;;                 |        |              |
+;; as:fo    [tab]  |  "fo"  |     "as"     | NIL              
+;;                 |        |              |
+;; :        [tab]  |   ""   |      ""      | #<PACKAGE "KEYWORD">
+;;                 |        |              |
+;; :foo     [tab]  | "foo"  |      ""      | #<PACKAGE "KEYWORD">
+;;
+(defun parse-completion-arguments (string default-package-name)
+  "Parse STRING as a symbol designator.
+Return these values:
+ SYMBOL-NAME
+ PACKAGE-NAME, or nil if the designator does not include an explicit package.
+ PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is
+          NIL, return the respective package of DEFAULT-PACKAGE-NAME instead;
+          if PACKAGE is non-NIL but a package cannot be found under that name,
+          return NIL.)
+ INTERNAL-P, if the symbol is qualified with `::'."
+  (multiple-value-bind (name package-name internal-p)
+      (tokenize-symbol string)
+    (flet ((default-package ()
+	     (or (guess-package default-package-name) *buffer-package*)))
+      (let ((package (cond
+		       ((not package-name)
+			(default-package))
+		       ((equal package-name "")
+			(guess-package (symbol-name :keyword)))
+		       ((find-locally-nicknamed-package
+			 package-name (default-package)))
+		       (t
+			(guess-package package-name)))))
+	(values name package-name package internal-p)))))
+
+(defun completion-output-case-converter (input &optional with-escaping-p)
+  "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case."
+  (ecase (readtable-case *readtable*)
+    (:upcase (cond ((or with-escaping-p
+                        (and (plusp (length input))
+                             (not (some #'lower-case-p input))))
+                    #'identity)
+                   (t #'string-downcase)))
+    (:invert (lambda (output)
+               (multiple-value-bind (lower upper) (determine-case output)
+                 (cond ((and lower upper) output)
+                       (lower (string-upcase output))
+                       (upper (string-downcase output))
+                       (t output)))))
+    (:downcase (cond ((or with-escaping-p
+                          (and (zerop (length input))
+                               (not (some #'upper-case-p input))))
+                      #'identity)
+                     (t #'string-upcase)))
+    (:preserve #'identity)))
+
+(defun completion-output-package-converter (input)
+  "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case."
+  (completion-output-case-converter input))
+
+(defun completion-output-symbol-converter (input)
+  "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case. Escape symbols when needed."
+  (let ((case-converter (completion-output-case-converter input))
+        (case-converter-with-escaping (completion-output-case-converter input t)))
+    (lambda (str)
+      (if (or (multiple-value-bind (lowercase uppercase)
+                  (determine-case str)
+                ;; In these readtable cases, symbols with letters from
+                ;; the wrong case need escaping
+                (case (readtable-case *readtable*)
+                  (:upcase   lowercase)
+                  (:downcase uppercase)
+                  (t         nil)))
+              (some (lambda (el)
+                      (or (member el '(#\: #\Space #\Newline #\Tab))
+                          (multiple-value-bind (macrofun nonterminating)
+                              (get-macro-character el)
+                            (and macrofun
+                                 (not nonterminating)))))
+                    str))
+          (concatenate 'string "|" (funcall case-converter-with-escaping str) "|")
+          (funcall case-converter str)))))
+
+
+(defun determine-case (string)
+  "Return two booleans LOWER and UPPER indicating whether STRING
+contains lower or upper case characters."
+  (values (some #'lower-case-p string)
+          (some #'upper-case-p string)))
+
+
+;;;;; Compound-prefix matching
+
+(defun make-compound-prefix-matcher (delimiter &key (test #'char=))
+  "Returns a matching function that takes a `prefix' and a
+`target' string and which returns T if `prefix' is a
+compound-prefix of `target', and otherwise NIL.
+
+Viewing each of `prefix' and `target' as a series of substrings
+delimited by DELIMITER, if each substring of `prefix' is a prefix
+of the corresponding substring in `target' then we call `prefix'
+a compound-prefix of `target'.
+
+DELIMITER may be a character, or a list of characters."
+  (let ((delimiters (etypecase delimiter
+		      (character (list delimiter))
+		      (cons      (assert (every #'characterp delimiter))
+			         delimiter))))
+    (lambda (prefix target)
+      (declare (type simple-string prefix target))
+      (loop with tpos = 0
+	    for ch across prefix
+	    always (and (< tpos (length target))
+			(let ((delimiter (car (member ch delimiters :test test))))
+			  (if delimiter
+			      (setf tpos (position delimiter target :start tpos))
+			      (funcall test ch (aref target tpos)))))
+	    do (incf tpos)))))
+
+
+;;;;; Extending the input string by completion
+
+(defun longest-compound-prefix (completions &optional (delimiter #\-))
+  "Return the longest compound _prefix_ for all COMPLETIONS."
+  (flet ((tokenizer (string) (tokenize-completion string delimiter)))
+    (untokenize-completion
+     (loop for token-list in (transpose-lists (mapcar #'tokenizer completions))
+           if (notevery #'string= token-list (rest token-list))
+           ;; Note that we possibly collect the "" here as well, so that
+           ;; UNTOKENIZE-COMPLETION will append a delimiter for us.
+             collect (longest-common-prefix token-list)
+             and do (loop-finish)
+           else collect (first token-list))
+     delimiter)))
+
+(defun tokenize-completion (string delimiter)
+  "Return all substrings of STRING delimited by DELIMITER."
+  (loop with end
+        for start = 0 then (1+ end)
+        until (> start (length string))
+        do (setq end (or (position delimiter string :start start) (length string)))
+        collect (subseq string start end)))
+
+(defun untokenize-completion (tokens &optional (delimiter #\-))
+  (format nil (format nil "~~{~~A~~^~a~~}" delimiter) tokens))
+
+(defun transpose-lists (lists)
+  "Turn a list-of-lists on its side.
+If the rows are of unequal length, truncate uniformly to the shortest.
+
+For example:
+\(transpose-lists '((ONE TWO THREE) (1 2)))
+  => ((ONE 1) (TWO 2))"
+  (cond ((null lists) '())
+        ((some #'null lists) '())
+        (t (cons (mapcar #'car lists)
+                 (transpose-lists (mapcar #'cdr lists))))))
+
+
+;;;; Completion for character names
+
+(defslimefun completions-for-character (prefix)
+  (let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal))
+         (completion-set (character-completion-set prefix matcher))
+         (completions (sort completion-set #'string<)))
+    (list completions (longest-compound-prefix completions #\_))))
+
+(provide :swank-c-p-c)

sources_non_forked/slimv/slime/contrib/swank-clipboard.lisp

@@ -0,0 +1,71 @@
+;;; swank-clipboard.lisp --- Object clipboard
+;;
+;; Written by Helmut Eller in 2008.
+;; License: Public Domain
+
+(defpackage :swank-clipboard
+  (:use :cl)
+  (:import-from :swank :defslimefun :with-buffer-syntax :dcase)
+  (:export :add :delete-entry :entries :entry-to-ref :ref))
+
+(in-package :swank-clipboard)
+
+(defstruct clipboard entries (counter 0))
+
+(defvar *clipboard* (make-clipboard))
+
+(defslimefun add (datum)
+  (let ((value (dcase datum
+		 ((:string string package)
+		  (with-buffer-syntax (package)
+		    (eval (read-from-string string))))
+		 ((:inspector part) 
+		  (swank:inspector-nth-part part))
+		 ((:sldb frame var)
+		  (swank/backend:frame-var-value frame var)))))
+    (clipboard-add value)
+    (format nil "Added: ~a"
+	    (entry-to-string (1- (length (clipboard-entries *clipboard*)))))))
+
+(defslimefun entries ()
+  (loop for (ref . value) in (clipboard-entries *clipboard*)
+	collect `(,ref . ,(to-line value))))
+
+(defslimefun delete-entry (entry)
+  (let ((msg (format nil "Deleted: ~a" (entry-to-string entry))))
+    (clipboard-delete-entry entry)
+    msg))
+
+(defslimefun entry-to-ref (entry)
+  (destructuring-bind (ref . value) (clipboard-entry entry)
+    (list ref (to-line value 5))))
+
+(defun clipboard-add (value)
+  (setf (clipboard-entries *clipboard*)
+	(append (clipboard-entries *clipboard*) 
+		(list (cons (incf (clipboard-counter *clipboard*))
+			    value)))))
+
+(defun clipboard-ref (ref)
+  (let ((tail (member ref (clipboard-entries *clipboard*) :key #'car)))
+    (cond (tail (cdr (car tail)))
+	  (t (error "Invalid clipboard ref: ~s" ref)))))
+
+(defun clipboard-entry (entry)
+  (elt (clipboard-entries *clipboard*) entry))
+
+(defun clipboard-delete-entry (index)
+  (let* ((list (clipboard-entries *clipboard*))
+	 (tail (nthcdr index list)))
+    (setf (clipboard-entries *clipboard*)
+	  (append (ldiff list tail) (cdr tail)))))
+
+(defun entry-to-string (entry)
+  (destructuring-bind (ref . value) (clipboard-entry entry)
+    (format nil "#@~d(~a)" ref (to-line value))))
+
+(defun to-line  (object &optional (width 75))
+  (with-output-to-string (*standard-output*)
+    (write object :right-margin width :lines 1)))
+
+(provide :swank-clipboard)

sources_non_forked/slimv/slime/contrib/swank-fuzzy.lisp

@@ -0,0 +1,706 @@
+;;; swank-fuzzy.lisp --- fuzzy symbol completion
+;;
+;; Authors: Brian Downing <bdowning@lavos.net>
+;;          Tobias C. Rittweiler <tcr@freebits.de>
+;;          and others
+;;
+;; License: Public Domain
+;;
+
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (swank-require :swank-util)
+  (swank-require :swank-c-p-c))
+
+(defvar *fuzzy-duplicate-symbol-filter* :nearest-package
+  "Specifies how fuzzy-matching handles \"duplicate\" symbols.
+Possible values are :NEAREST-PACKAGE, :HOME-PACKAGE, :ALL, or a custom
+function. See Fuzzy Completion in the manual for details.")
+
+(export '*fuzzy-duplicate-symbol-filter*)
+
+;;; For nomenclature of the fuzzy completion section, please read
+;;; through the following docstring.
+
+(defslimefun fuzzy-completions (string default-package-name
+                                &key limit time-limit-in-msec)
+"Returns a list of two values:
+
+  An (optionally limited to LIMIT best results) list of fuzzy
+  completions for a symbol designator STRING. The list will be
+  sorted by score, most likely match first.
+
+  A flag that indicates whether or not TIME-LIMIT-IN-MSEC has
+  been exhausted during computation. If that parameter's value is
+  NIL or 0, no time limit is assumed.
+
+The main result is a list of completion objects, where a completion
+object is:
+
+    (COMPLETED-STRING SCORE (&rest CHUNKS) CLASSIFICATION-STRING)
+
+where a CHUNK is a description of a matched substring:
+
+    (OFFSET SUBSTRING)
+
+and FLAGS is short string describing properties of the symbol (see
+SYMBOL-CLASSIFICATION-STRING).
+
+E.g., completing \"mvb\" in a package that uses COMMON-LISP would
+return something like:
+
+    ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\"))
+     (:FBOUNDP :MACRO))
+     ...)
+
+If STRING is package qualified the result list will also be
+qualified.  If string is non-qualified the result strings are
+also not qualified and are considered relative to
+DEFAULT-PACKAGE-NAME.
+
+Which symbols are candidates for matching depends on the symbol
+designator's format. The cases are as follows:
+  FOO      - Symbols accessible in the buffer package.
+  PKG:FOO  - Symbols external in package PKG.
+  PKG::FOO - Symbols accessible in package PKG."
+  ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC
+  ;; to denote an infinite time limit. Internally, we only use NIL for
+  ;; that purpose, to be able to distinguish between "no time limit
+  ;; alltogether" and "current time limit already exhausted." So we've
+  ;; got to canonicalize its value at first:
+  (let* ((no-time-limit-p (or (not time-limit-in-msec)
+                              (zerop time-limit-in-msec)))
+         (time-limit (if no-time-limit-p nil time-limit-in-msec)))
+    (multiple-value-bind (completion-set interrupted-p)
+        (fuzzy-completion-set string default-package-name :limit limit
+                              :time-limit-in-msec time-limit)
+      ;; We may send this as elisp [] arrays to spare a coerce here,
+      ;; but then the network serialization were slower by handling arrays.
+      ;; Instead we limit the number of completions that is transferred
+      ;; (the limit is set from Emacs.)
+      (list (coerce completion-set 'list) interrupted-p))))
+
+
+;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion
+;;; object that will be sent back to Emacs, as described above.
+
+(defstruct (fuzzy-matching (:conc-name fuzzy-matching.)
+                           (:predicate fuzzy-matching-p)
+                           (:constructor make-fuzzy-matching
+                               (symbol package-name score package-chunks
+                                symbol-chunks &key (symbol-p t))))
+  symbol            ; The symbol that has been found to match.
+  symbol-p          ; To deffirentiate between completeing
+                    ; package: and package:nil
+  package-name      ; The name of the package where SYMBOL was found in.
+                    ;  (This is not necessarily the same as the home-package
+                    ;   of SYMBOL, because the SYMBOL can be internal to
+                    ;   lots of packages; also think of package nicknames.)
+  score             ; The higher the better SYMBOL is a match.
+  package-chunks    ; Chunks pertaining to the package identifier of SYMBOL.
+  symbol-chunks)    ; Chunks pertaining to SYMBOL's name.
+
+(defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string)
+  (multiple-value-bind (_ user-package-name __ input-internal-p)
+      (parse-completion-arguments user-input-string nil)
+    (declare (ignore _ __))
+    (with-struct (fuzzy-matching. score symbol package-name package-chunks
+                                  symbol-chunks symbol-p)
+        fuzzy-matching
+      (let (symbol-name real-package-name internal-p)
+        (cond (symbol-p ; symbol fuzzy matching?
+               (setf symbol-name (symbol-name symbol))
+               (setf internal-p input-internal-p)
+               (setf real-package-name (cond ((keywordp symbol)     "")
+                                             ((not user-package-name) nil)
+                                             (t package-name))))
+              (t      ; package fuzzy matching?
+               (setf symbol-name "")
+               (setf real-package-name package-name)
+               ;; If no explicit package name was given by the user
+               ;; (e.g. input was "asdf"), we want to append only
+               ;; one colon ":" to the package names.
+               (setf internal-p (if user-package-name input-internal-p nil))))
+        (values symbol-name
+                real-package-name
+                (if user-package-name internal-p nil)
+                (completion-output-symbol-converter user-input-string)
+                (completion-output-package-converter user-input-string))))))
+
+(defun fuzzy-format-matching (fuzzy-matching user-input-string)
+  "Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING."
+  (multiple-value-bind (symbol-name package-name internal-p
+                        symbol-converter package-converter)
+      (%fuzzy-extract-matching-info fuzzy-matching user-input-string)
+    (setq symbol-name (and symbol-name
+                           (funcall symbol-converter symbol-name)))
+    (setq package-name (and package-name
+                            (funcall package-converter package-name)))
+    (let ((result (untokenize-symbol package-name internal-p symbol-name)))
+      ;; We return the length of the possibly added prefix as second value.
+      (values result (search symbol-name result)))))
+
+(defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string)
+  "Converts a result from the fuzzy completion core into something
+that emacs is expecting.  Converts symbols to strings, fixes case
+issues, and adds information (as a string) describing if the symbol is
+bound, fbound, a class, a macro, a generic-function, a
+special-operator, or a package."
+  (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks
+                                symbol-p)
+               fuzzy-matching
+    (multiple-value-bind (name added-length)
+        (fuzzy-format-matching fuzzy-matching user-input-string)
+      (list name
+            (format nil "~,2f" score)
+            (append package-chunks
+                    (mapcar (lambda (chunk)
+                              ;; Fix up chunk positions to account for possible
+                              ;; added package identifier.
+                              (let ((offset (first chunk))
+                                    (string (second chunk)))
+                                (list (+ added-length offset) string)))
+                            symbol-chunks))
+            (if symbol-p
+                (symbol-classification-string symbol)
+                "-------p")))))
+
+(defun fuzzy-completion-set (string default-package-name
+                             &key limit time-limit-in-msec)
+  "Returns two values: an array of completion objects, sorted by
+their score, that is how well they are a match for STRING
+according to the fuzzy completion algorithm.  If LIMIT is set,
+only the top LIMIT results will be returned. Additionally, a flag
+is returned that indicates whether or not TIME-LIMIT-IN-MSEC was
+exhausted."
+  (check-type limit (or null (integer 0 #.(1- most-positive-fixnum))))
+  (check-type time-limit-in-msec
+              (or null (integer 0 #.(1- most-positive-fixnum))))
+  (multiple-value-bind (matchings interrupted-p)
+      (fuzzy-generate-matchings string default-package-name time-limit-in-msec)
+    (when (and limit
+               (> limit 0)
+               (< limit (length matchings)))
+      (if (array-has-fill-pointer-p matchings)
+          (setf (fill-pointer matchings) limit)
+          (setf matchings (make-array limit :displaced-to matchings))))
+    (map-into matchings #'(lambda (m)
+                            (fuzzy-convert-matching-for-emacs m string))
+              matchings)
+    (values matchings interrupted-p)))
+
+
+(defun fuzzy-generate-matchings (string default-package-name
+                                 time-limit-in-msec)
+  "Does all the hard work for FUZZY-COMPLETION-SET. If
+TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed."
+  (multiple-value-bind (parsed-symbol-name parsed-package-name
+                        package internal-p)
+      (parse-completion-arguments string default-package-name)
+    (flet ((fix-up (matchings parent-package-matching)
+             ;; The components of each matching in MATCHINGS have been computed
+             ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute.
+             (let* ((p parent-package-matching)
+                    (p.name   (fuzzy-matching.package-name p))
+                    (p.score  (fuzzy-matching.score p))
+                    (p.chunks (fuzzy-matching.package-chunks p)))
+               (map-into
+                matchings
+                (lambda (m)
+                  (let ((m.score (fuzzy-matching.score m)))
+                    (setf (fuzzy-matching.package-name m) p.name)
+                    (setf (fuzzy-matching.package-chunks m) p.chunks)
+                    (setf (fuzzy-matching.score m)
+                          (if (equal parsed-symbol-name "")
+                              ;; Make package matchings be sorted before all
+                              ;; the relative symbol matchings while preserving
+                              ;; over all orderness.
+                              (/ p.score 100)
+                              (+ p.score m.score)))
+                    m))
+                matchings)))
+           (find-symbols (designator package time-limit &optional filter)
+             (fuzzy-find-matching-symbols designator package
+                                          :time-limit-in-msec time-limit
+                                          :external-only (not internal-p)
+                                          :filter (or filter #'identity)))
+           (find-packages (designator time-limit)
+             (fuzzy-find-matching-packages designator
+                                           :time-limit-in-msec time-limit))
+           (maybe-find-local-package (name)
+             (or (find-locally-nicknamed-package name *buffer-package*)
+                 (find-package name))))
+      (let ((time-limit time-limit-in-msec) (symbols) (packages) (results)
+            (dedup-table (make-hash-table :test #'equal)))
+        (cond ((not parsed-package-name) ; E.g. STRING = "asd"
+               ;; We don't know if user is searching for a package or a symbol
+               ;; within his current package. So we try to find either.
+               (setf (values packages time-limit)
+                     (find-packages parsed-symbol-name time-limit))
+               (setf (values symbols  time-limit)
+                     (find-symbols parsed-symbol-name package time-limit)))
+              ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo"
+               (setf (values symbols time-limit)
+                     (find-symbols parsed-symbol-name package time-limit)))
+              (t                   ; E.g. STRING = "asd:" or "asd:foo"
+               ;; Find fuzzy matchings of the denoted package identifier part.
+               ;; After that, find matchings for the denoted symbol identifier
+               ;; relative to all the packages found.
+               (multiple-value-bind (symbol-packages rest-time-limit)
+                   (find-packages parsed-package-name time-limit-in-msec)
+                 ;; We want to traverse the found packages in the order of
+                 ;; their score, since those with higher score presumably
+                 ;; represent better choices.  (This is important because some
+                 ;; packages may never be looked at if time limit exhausts
+                 ;; during traversal.)
+                 (setf symbol-packages
+                       (sort symbol-packages #'fuzzy-matching-greaterp))
+                 (loop
+                   for package-matching across symbol-packages
+                   for package = (maybe-find-local-package
+                                  (fuzzy-matching.package-name
+                                   package-matching))
+                   while (or (not time-limit) (> rest-time-limit 0)) do
+                   (multiple-value-bind (matchings remaining-time)
+                       ;; The duplication filter removes all those symbols
+                       ;; which are present in more than one package
+                       ;; match. See *FUZZY-DUPLICATE-SYMBOL-FILTER*
+                       (find-symbols parsed-symbol-name package rest-time-limit
+                                     (%make-duplicate-symbols-filter
+                                      package-matching symbol-packages dedup-table))
+                     (setf matchings (fix-up matchings package-matching))
+                     (setf symbols   (concatenate 'vector symbols matchings))
+                     (setf rest-time-limit remaining-time)
+                     (let ((guessed-sort-duration
+                             (%guess-sort-duration (length symbols))))
+                       (when (and rest-time-limit
+                                  (<= rest-time-limit guessed-sort-duration))
+                         (decf rest-time-limit guessed-sort-duration)
+                         (loop-finish))))
+                   finally
+                   (setf time-limit rest-time-limit)
+                   (when (equal parsed-symbol-name "") ; E.g. STRING = "asd:"
+                     (setf packages symbol-packages))))))
+        ;; Sort by score; thing with equal score, sort alphabetically.
+        ;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all
+        ;; possible completions are to be returned.)
+        (setf results (concatenate 'vector symbols packages))
+        (setf results (sort results #'fuzzy-matching-greaterp))
+        (values results (and time-limit (<= time-limit 0)))))))
+
+(defun %guess-sort-duration (length)
+  ;; These numbers are pretty much arbitrary, except that they're
+  ;; vaguely correct on my machine with SBCL. Yes, this is an ugly
+  ;; kludge, but it's better than before (where this didn't exist at
+  ;; all, which essentially meant, that this was taken to be 0.)
+  (if (zerop length)
+      0
+      (let ((comparasions (* 3.8 (* length (log length 2)))))
+        (* 1000 (* comparasions (expt 10 -7)))))) ; msecs
+
+(defun %make-duplicate-symbols-filter (current-package-matching fuzzy-package-matchings dedup-table)
+  ;; Returns a filter function based on *FUZZY-DUPLICATE-SYMBOL-FILTER*.
+  (case *fuzzy-duplicate-symbol-filter*
+    (:home-package
+     ;; Return a filter function that takes a symbol, and which returns T
+     ;; if and only if /no/ matching in FUZZY-PACKAGE-MATCHINGS represents
+     ;; the home-package of the symbol passed.
+     (let ((packages (mapcar #'(lambda (m)
+                                 (find-package (fuzzy-matching.package-name m)))
+                             (remove current-package-matching
+                                     (coerce fuzzy-package-matchings 'list)))))
+       #'(lambda (symbol)
+           (not (member (symbol-package symbol) packages)))))
+    (:nearest-package
+     ;; Keep only the first occurence of the symbol.
+     #'(lambda (symbol)
+         (unless (gethash (symbol-name symbol) dedup-table)
+           (setf (gethash (symbol-name symbol) dedup-table) t))))
+    (:all
+     ;; No filter
+     #'identity)
+    (t
+     (typecase *fuzzy-duplicate-symbol-filter*
+       (function
+        ;; Custom filter
+        (funcall *fuzzy-duplicate-symbol-filter*
+                 (fuzzy-matching.package-name current-package-matching)
+                 (map 'list #'fuzzy-matching.package-name fuzzy-package-matchings)
+                 dedup-table))
+       (t
+        ;; Bad filter value
+        (warn "bad *FUZZY-DUPLICATE-SYMBOL-FILTER* value: ~s"
+              *fuzzy-duplicate-symbol-filter*)
+        #'identity)))))
+
+(defun fuzzy-matching-greaterp (m1 m2)
+  "Returns T if fuzzy-matching M1 should be sorted before M2.
+Basically just the scores of the two matchings are compared, and
+the match with higher score wins. For the case that the score is
+equal, the one which comes alphabetically first wins."
+  (declare (type fuzzy-matching m1 m2))
+  (let ((score1 (fuzzy-matching.score m1))
+        (score2 (fuzzy-matching.score m2)))
+    (cond ((> score1 score2) t)
+          ((< score1 score2) nil)       ; total order
+          (t
+           (let ((name1 (symbol-name (fuzzy-matching.symbol m1)))
+                 (name2 (symbol-name (fuzzy-matching.symbol m2))))
+             (string< name1 name2))))))
+
+(declaim (ftype (function () (integer 0)) get-real-time-msecs))
+(defun get-real-time-in-msecs ()
+  (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000))))
+    (values (floor (get-internal-real-time) units-per-msec))))
+
+(defun fuzzy-find-matching-symbols
+    (string package &key (filter #'identity) external-only time-limit-in-msec)
+  "Returns two values: a vector of fuzzy matchings for matching
+symbols in PACKAGE, using the fuzzy completion algorithm, and the
+remaining time limit.
+
+Only those symbols are considered of which FILTER does return T.
+
+If EXTERNAL-ONLY is true, only external symbols are considered. A
+TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or
+negative, perform a NOP."
+  (let ((time-limit-p (and time-limit-in-msec t))
+        (time-limit (or time-limit-in-msec 0))
+        (rtime-at-start (get-real-time-in-msecs))
+        (package-name (package-name package))
+        (count 0))
+    (declare (type boolean time-limit-p))
+    (declare (type integer time-limit rtime-at-start))
+    (declare (type (integer 0 #.(1- most-positive-fixnum)) count))
+
+    (flet ((recompute-remaining-time (old-remaining-time)
+             (cond ((not time-limit-p)
+                    ;; propagate NIL back as infinite time limit
+                    (values nil nil))
+                   ((> count 0) ; ease up on getting internal time like crazy
+                    (setf count (mod (1+ count) 128))
+                    (values nil old-remaining-time))
+                   (t (let* ((elapsed-time (- (get-real-time-in-msecs)
+                                              rtime-at-start))
+                             (remaining (- time-limit elapsed-time)))
+                        (values (<= remaining 0) remaining)))))
+           (perform-fuzzy-match (string symbol-name)
+             (let* ((converter (completion-output-symbol-converter string))
+                    (converted-symbol-name (funcall converter symbol-name)))
+               (compute-highest-scoring-completion string
+                                                   converted-symbol-name))))
+      (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
+            (rest-time-limit time-limit))
+        (do-symbols* (symbol package)
+          (multiple-value-bind (exhausted? remaining-time)
+              (recompute-remaining-time rest-time-limit)
+            (setf rest-time-limit remaining-time)
+            (cond (exhausted? (return))
+                  ((not (and (or (not external-only)
+                                 (symbol-external-p symbol package))
+                             (funcall filter symbol))))
+                  ((string= "" string) ; "" matches always
+                   (vector-push-extend
+                    (make-fuzzy-matching symbol package-name
+                                         0.0 '() '())
+                    completions))
+                  (t
+                   (multiple-value-bind (match-result score)
+                       (perform-fuzzy-match string (symbol-name symbol))
+                     (when match-result
+                       (vector-push-extend
+                        (make-fuzzy-matching symbol package-name score
+                                             '() match-result)
+                        completions)))))))
+        (values completions rest-time-limit)))))
+
+(defun fuzzy-find-matching-packages (name &key time-limit-in-msec)
+  "Returns a vector of fuzzy matchings for each package that is
+similiar to NAME, and the remaining time limit.
+Cf. FUZZY-FIND-MATCHING-SYMBOLS."
+  (let ((time-limit-p (and time-limit-in-msec t))
+        (time-limit (or time-limit-in-msec 0))
+        (rtime-at-start (get-real-time-in-msecs))
+        (converter (completion-output-package-converter name))
+        (completions (make-array 32 :adjustable t :fill-pointer 0)))
+    (declare (type boolean time-limit-p))
+    (declare (type integer time-limit rtime-at-start))
+    (declare (type function converter))
+    (flet ((match-package (names)
+             (loop with max-pkg-name = ""
+                   with max-result   = nil
+                   with max-score    = 0
+                   for package-name in names
+                   for converted-name = (funcall converter package-name)
+                   do
+                   (multiple-value-bind (result score)
+                       (compute-highest-scoring-completion name
+                                                           converted-name)
+                     (when (and result (> score max-score))
+                       (setf max-pkg-name package-name)
+                       (setf max-result   result)
+                       (setf max-score    score)))
+                   finally
+                   (when max-result
+                     (vector-push-extend
+                      (make-fuzzy-matching nil max-pkg-name
+                                           max-score max-result '()
+                                           :symbol-p nil)
+                      completions)))))
+     (cond ((and time-limit-p (<= time-limit 0))
+            (values #() time-limit))
+           (t
+            (loop for (nick) in (package-local-nicknames *buffer-package*)
+                  do
+                  (match-package (list nick)))
+            (loop for package in (list-all-packages)
+                  do
+                  ;; Find best-matching package-nickname:
+                  (match-package (package-names package))
+                  finally
+                  (return
+                    (values completions
+                            (and time-limit-p
+                                 (let ((elapsed-time (- (get-real-time-in-msecs)
+                                                        rtime-at-start)))
+                                   (- time-limit elapsed-time)))))))))))
+
+
+(defslimefun fuzzy-completion-selected (original-string completion)
+  "This function is called by Slime when a fuzzy completion is
+selected by the user.  It is for future expansion to make
+testing, say, a machine learning algorithm for completion scoring
+easier.
+
+ORIGINAL-STRING is the string the user completed from, and
+COMPLETION is the completion object (see docstring for
+SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the
+user selected."
+  (declare (ignore original-string completion))
+  nil)
+
+
+;;;;; Fuzzy completion core
+
+(defparameter *fuzzy-recursion-soft-limit* 30
+  "This is a soft limit for recursion in
+RECURSIVELY-COMPUTE-MOST-COMPLETIONS.  Without this limit,
+completing a string such as \"ZZZZZZ\" with a symbol named
+\"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to
+find all the ways it can match.
+
+Most natural language searches and symbols do not have this
+problem -- this is only here as a safeguard.")
+(declaim (fixnum *fuzzy-recursion-soft-limit*))
+
+(defvar *all-chunks* '())
+(declaim (type list *all-chunks*))
+
+(defun compute-highest-scoring-completion (short full)
+  "Finds the highest scoring way to complete the abbreviation
+SHORT onto the string FULL, using CHAR= as a equality function for
+letters.  Returns two values:  The first being the completion
+chunks of the highest scorer, and the second being the score."
+  (let* ((scored-results
+          (mapcar #'(lambda (result)
+                      (cons (score-completion result short full) result))
+                  (compute-most-completions short full)))
+         (winner (first (sort scored-results #'> :key #'first))))
+    (values (rest winner) (first winner))))
+
+(defun compute-most-completions (short full)
+  "Finds most possible ways to complete FULL with the letters in SHORT.
+Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively.  Returns
+a list of (&rest CHUNKS), where each CHUNKS is a description of
+how a completion matches."
+  (let ((*all-chunks* nil))
+    (recursively-compute-most-completions short full 0 0 nil nil nil t)
+    *all-chunks*))
+
+(defun recursively-compute-most-completions
+    (short full
+     short-index initial-full-index
+     chunks current-chunk current-chunk-pos
+     recurse-p)
+  "Recursively (if RECURSE-P is true) find /most/ possible ways
+to fuzzily map the letters in SHORT onto FULL, using CHAR= to
+determine if two letters match.
+
+A chunk is a list of elements that have matched consecutively.
+When consecutive matches stop, it is coerced into a string,
+paired with the starting position of the chunk, and pushed onto
+CHUNKS.
+
+Whenever a letter matches, if RECURSE-P is true,
+RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position
+one index ahead, to find other possibly higher scoring
+possibilities.  If there are less than
+*FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently,
+this call will also recurse.
+
+Once a word has been completely matched, the chunks are pushed
+onto the special variable *ALL-CHUNKS* and the function returns."
+  (declare (optimize speed)
+           (type fixnum short-index initial-full-index)
+           (type list current-chunk)
+           (simple-string short full))
+  (flet ((short-cur ()
+           "Returns the next letter from the abbreviation, or NIL
+            if all have been used."
+           (if (= short-index (length short))
+               nil
+               (aref short short-index)))
+         (add-to-chunk (char pos)
+           "Adds the CHAR at POS in FULL to the current chunk,
+            marking the start position if it is empty."
+           (unless current-chunk
+             (setf current-chunk-pos pos))
+           (push char current-chunk))
+         (collect-chunk ()
+           "Collects the current chunk to CHUNKS and prepares for
+            a new chunk."
+           (when current-chunk
+             (let ((current-chunk-as-string
+                     (nreverse
+                      (make-array (length current-chunk)
+                                  :element-type 'character
+                                  :initial-contents current-chunk))))
+               (push (list current-chunk-pos current-chunk-as-string) chunks)
+               (setf current-chunk nil
+                     current-chunk-pos nil)))))
+    ;; If there's an outstanding chunk coming in collect it.  Since
+    ;; we're recursively called on skipping an input character, the
+    ;; chunk can't possibly continue on.
+    (when current-chunk (collect-chunk))
+    (do ((pos initial-full-index (1+ pos)))
+        ((= pos (length full)))
+      (let ((cur-char (aref full pos)))
+        (if (and (short-cur)
+                 (char= cur-char (short-cur)))
+            (progn
+              (when recurse-p
+                ;; Try other possibilities, limiting insanely deep
+                ;; recursion somewhat.
+                (recursively-compute-most-completions
+                 short full short-index (1+ pos)
+                 chunks current-chunk current-chunk-pos
+                 (not (> (length *all-chunks*)
+                         *fuzzy-recursion-soft-limit*))))
+              (incf short-index)
+              (add-to-chunk cur-char pos))
+            (collect-chunk))))
+    (collect-chunk)
+    ;; If we've exhausted the short characters we have a match.
+    (if (short-cur)
+        nil
+        (let ((rev-chunks (reverse chunks)))
+          (push rev-chunks *all-chunks*)
+          rev-chunks))))
+
+
+;;;;; Fuzzy completion scoring
+
+(defvar *fuzzy-completion-symbol-prefixes* "*+-%&?<"
+  "Letters that are likely to be at the beginning of a symbol.
+Letters found after one of these prefixes will be scored as if
+they were at the beginning of ths symbol.")
+(defvar *fuzzy-completion-symbol-suffixes* "*+->"
+  "Letters that are likely to be at the end of a symbol.
+Letters found before one of these suffixes will be scored as if
+they were at the end of the symbol.")
+(defvar *fuzzy-completion-word-separators* "-/."
+  "Letters that separate different words in symbols.  Letters
+after one of these symbols will be scores more highly than other
+letters.")
+
+(defun score-completion (completion short full)
+  "Scores the completion chunks COMPLETION as a completion from
+the abbreviation SHORT to the full string FULL.  COMPLETION is a
+list like:
+    ((0 \"mul\") (9 \"v\") (15 \"b\"))
+Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\",
+would indicate that it completed as such (completed letters
+capitalized):
+    MULtiple-Value-Bind
+
+Letters are given scores based on their position in the string.
+Letters at the beginning of a string or after a prefix letter at
+the beginning of a string are scored highest.  Letters after a
+word separator such as #\- are scored next highest.  Letters at
+the end of a string or before a suffix letter at the end of a
+string are scored medium, and letters anywhere else are scored
+low.
+
+If a letter is directly after another matched letter, and its
+intrinsic value in that position is less than a percentage of the
+previous letter's value, it will use that percentage instead.
+
+Finally, a small scaling factor is applied to favor shorter
+matches, all other things being equal."
+  (labels ((at-beginning-p (pos)
+             (= pos 0))
+           (after-prefix-p (pos)
+             (and (= pos 1)
+                  (find (aref full 0) *fuzzy-completion-symbol-prefixes*)))
+           (word-separator-p (pos)
+             (find (aref full pos) *fuzzy-completion-word-separators*))
+           (after-word-separator-p (pos)
+             (find (aref full (1- pos)) *fuzzy-completion-word-separators*))
+           (at-end-p (pos)
+             (= pos (1- (length full))))
+           (before-suffix-p (pos)
+             (and (= pos (- (length full) 2))
+                  (find (aref full (1- (length full)))
+                        *fuzzy-completion-symbol-suffixes*)))
+           (score-or-percentage-of-previous (base-score pos chunk-pos)
+             (if (zerop chunk-pos)
+                 base-score
+                 (max base-score
+                      (+ (* (score-char (1- pos) (1- chunk-pos)) 0.85)
+                         (expt 1.2 chunk-pos)))))
+           (score-char (pos chunk-pos)
+             (score-or-percentage-of-previous
+              (cond ((at-beginning-p pos)         10)
+                    ((after-prefix-p pos)         10)
+                    ((word-separator-p pos)       1)
+                    ((after-word-separator-p pos) 8)
+                    ((at-end-p pos)               6)
+                    ((before-suffix-p pos)        6)
+                    (t                            1))
+              pos chunk-pos))
+           (score-chunk (chunk)
+             (loop for chunk-pos below (length (second chunk))
+                   for pos from (first chunk)
+                   summing (score-char pos chunk-pos))))
+    (let* ((chunk-scores (mapcar #'score-chunk completion))
+           (length-score (/ 10.0 (1+ (- (length full) (length short))))))
+      (values
+       (+ (reduce #'+ chunk-scores) length-score)
+       (list (mapcar #'list chunk-scores completion) length-score)))))
+
+(defun highlight-completion (completion full)
+  "Given a chunk definition COMPLETION and the string FULL,
+HIGHLIGHT-COMPLETION will create a string that demonstrates where
+the completion matched in the string.  Matches will be
+capitalized, while the rest of the string will be lower-case."
+  (let ((highlit (nstring-downcase (copy-seq full))))
+    (dolist (chunk completion)
+      (setf highlit (nstring-upcase highlit
+                                    :start (first chunk)
+                                    :end (+ (first chunk)
+                                            (length (second chunk))))))
+    highlit))
+
+(defun format-fuzzy-completion-set (winners)
+  "Given a list of completion objects such as on returned by
+FUZZY-COMPLETION-SET, format the list into user-readable output
+for interactive debugging purpose."
+  (let ((max-len
+         (loop for winner in winners maximizing (length (first winner)))))
+    (loop for (sym score result) in winners do
+          (format t "~&~VA  score ~8,2F  ~A"
+                  max-len (highlight-completion result sym) score result))))
+
+(provide :swank-fuzzy)

sources_non_forked/slimv/slime/contrib/swank-hyperdoc.lisp

@@ -0,0 +1,18 @@
+(in-package :swank)
+
+(defslimefun hyperdoc (string)
+  (let ((hyperdoc-package (find-package :hyperdoc)))
+    (when hyperdoc-package
+      (multiple-value-bind (symbol foundp symbol-name package)
+          (parse-symbol string *buffer-package*)
+        (declare (ignore symbol))
+        (when foundp
+          (funcall (find-symbol (string :lookup) hyperdoc-package)
+                   (package-name (if (member package (cons *buffer-package*
+                                                           (package-use-list
+                                                            *buffer-package*)))
+                                     *buffer-package*
+                                     package))
+                   symbol-name))))))
+
+(provide :swank-hyperdoc)

sources_non_forked/slimv/slime/contrib/swank-indentation.lisp

@@ -0,0 +1,140 @@
+(in-package :swank)
+
+(defvar *application-hints-tables* '()
+  "A list of hash tables mapping symbols to indentation hints (lists 
+of symbols and numbers as per cl-indent.el). Applications can add hash 
+tables to the list to change the auto indentation slime sends to 
+emacs.")
+
+(defun has-application-indentation-hint-p (symbol)
+  (let ((default (load-time-value (gensym))))
+    (dolist (table *application-hints-tables*)
+      (let ((indentation (gethash symbol table default)))
+        (unless (eq default indentation)
+          (return-from has-application-indentation-hint-p
+            (values indentation t))))))
+  (values nil nil))
+
+(defun application-indentation-hint (symbol)
+  (let ((indentation (has-application-indentation-hint-p symbol)))
+    (labels ((walk (indentation-spec)
+               (etypecase indentation-spec
+                 (null nil)
+                 (number indentation-spec)
+                 (symbol (string-downcase indentation-spec))
+                 (cons (cons (walk (car indentation-spec))
+                             (walk (cdr indentation-spec)))))))
+      (walk indentation))))
+
+;;; override swank version of this function
+(defun symbol-indentation (symbol)
+  "Return a form describing the indentation of SYMBOL. 
+
+The form is to be used as the `common-lisp-indent-function' property 
+in Emacs."
+  (cond
+    ((has-application-indentation-hint-p symbol)
+     (application-indentation-hint symbol))
+    ((and (macro-function symbol)
+             (not (known-to-emacs-p symbol)))
+     (let ((arglist (arglist symbol)))
+       (etypecase arglist
+         ((member :not-available)
+          nil)
+         (list
+          (macro-indentation arglist)))))
+    (t nil)))
+
+;;; More complex version.
+(defun macro-indentation (arglist)
+  (labels ((frob (list &optional base)
+             (if (every (lambda (x)
+                          (member x '(nil "&rest") :test #'equal))
+                        list)
+                 ;; If there was nothing interesting, don't return anything.
+                 nil
+                 ;; Otherwise substitute leading NIL's with 4 or 1.
+                 (let ((ok t))
+                   (substitute-if (if base
+                                      4
+                                      1)
+                                  (lambda (x)
+                                    (if (and ok (not x))
+                                        t
+                                        (setf ok nil)))
+                                  list))))
+           (walk (list level &optional firstp)
+             (when (consp list)
+               (let ((head (car list)))
+                 (if (consp head)
+                     (let ((indent (frob (walk head (+ level 1) t))))
+                       (cons (list* "&whole" (if (zerop level)
+                                                 4
+                                                 1)
+                                    indent) (walk (cdr list) level)))
+                     (case head
+                       ;; &BODY is &BODY, this is clear.
+                       (&body
+                        '("&body"))
+                       ;; &KEY is tricksy. If it's at the base level, we want
+                       ;; to indent them normally:
+                       ;;
+                       ;;  (foo bar quux
+                       ;;       :quux t
+                       ;;       :zot nil)
+                       ;;
+                       ;; If it's at a destructuring level, we want indent of 1:
+                       ;;
+                       ;;  (with-foo (var arg
+                       ;;             :foo t
+                       ;;             :quux nil)
+                       ;;     ...)
+                       (&key
+                        (if (zerop level)
+                            '("&rest" nil)
+                            '("&rest" 1)))
+                       ;; &REST is tricksy. If it's at the front of
+                       ;; destructuring, we want to indent by 1, otherwise
+                       ;; normally:
+                       ;;
+                       ;;  (foo (bar quux
+                       ;;        zot)
+                       ;;    ...)
+                       ;;
+                       ;; but
+                       ;;
+                       ;;  (foo bar quux
+                       ;;       zot)
+                       (&rest
+                        (if (and (plusp level) firstp)
+                            '("&rest" 1)
+                            '("&rest" nil)))
+                       ;; &WHOLE and &ENVIRONMENT are skipped as if they weren't there
+                       ;; at all.
+                       ((&whole &environment)
+                        (walk (cddr list) level firstp))
+                       ;; &OPTIONAL is indented normally -- and the &OPTIONAL marker
+                       ;; itself is not counted.
+                       (&optional
+                        (walk (cdr list) level))
+                       ;; Indent normally, walk the tail -- but
+                       ;; unknown lambda-list keywords terminate the walk.
+                       (otherwise
+                        (unless (member head lambda-list-keywords)
+                          (cons nil (walk (cdr list) level))))))))))
+    (frob (walk arglist 0 t) t)))
+
+#+nil
+(progn
+  (assert (equal '(4 4 ("&whole" 4 "&rest" 1) "&body")
+                 (macro-indentation '(bar quux (&rest slots) &body body))))
+  (assert (equal nil
+                 (macro-indentation '(a b c &rest more))))
+  (assert (equal '(4 4 4 "&body")
+                 (macro-indentation '(a b c &body more))))
+  (assert (equal '(("&whole" 4 1 1 "&rest" 1) "&body")
+                 (macro-indentation '((name zot &key foo bar) &body body))))
+  (assert (equal nil
+                 (macro-indentation '(x y &key z)))))
+
+(provide :swank-indentation)

sources_non_forked/slimv/slime/contrib/swank-larceny.scm

@@ -0,0 +1,176 @@
+;; swank-larceny.scm --- Swank server for Larceny
+;;
+;; License: Public Domain
+;; Author: Helmut Eller
+;;
+;; In a shell execute:
+;;   larceny -r6rs -program swank-larceny.scm
+;; and then `M-x slime-connect' in Emacs.
+
+(library (swank os)
+    (export getpid make-server-socket accept local-port close-socket)
+    (import (rnrs)
+	    (primitives foreign-procedure 
+			ffi/handle->address
+			ffi/string->asciiz
+			sizeof:pointer
+			sizeof:int
+			%set-pointer
+			%get-int))
+
+ (define getpid (foreign-procedure "getpid" '() 'int))
+ (define fork (foreign-procedure "fork" '() 'int))
+ (define close (foreign-procedure "close" '(int) 'int))
+ (define dup2 (foreign-procedure "dup2" '(int int) 'int))
+
+ (define bytevector-content-offset$ sizeof:pointer)
+
+ (define execvp% (foreign-procedure "execvp" '(string boxed) 'int))
+ (define (execvp file . args)
+   (let* ((nargs (length args))
+	  (argv (make-bytevector (* (+ nargs 1)
+				    sizeof:pointer))))
+     (do ((offset 0 (+ offset sizeof:pointer))
+	  (as args (cdr as)))
+	 ((null? as))
+       (%set-pointer argv
+		     offset
+		     (+ (ffi/handle->address (ffi/string->asciiz (car as)))
+			bytevector-content-offset$)))
+     (%set-pointer argv (* nargs sizeof:pointer) 0)
+     (execvp% file argv)))
+
+ (define pipe% (foreign-procedure "pipe" '(boxed) 'int))
+ (define (pipe)
+   (let ((array (make-bytevector (* sizeof:int 2))))
+     (let ((r (pipe% array)))
+       (values r (%get-int array 0) (%get-int array sizeof:int)))))
+
+ (define (fork/exec file . args)
+   (let ((pid (fork)))
+     (cond ((= pid 0)
+	    (apply execvp file args))
+	   (#t pid))))
+ 
+ (define (start-process file . args)
+   (let-values (((r1 down-out down-in) (pipe))
+		((r2 up-out up-in) (pipe))
+		((r3 err-out err-in) (pipe)))
+     (assert (= 0 r1))
+     (assert (= 0 r2))
+     (assert (= 0 r3))
+     (let ((pid (fork)))
+       (case pid
+	 ((-1)
+	  (error "Failed to fork a subprocess."))
+	 ((0)
+	  (close up-out)
+	  (close err-out)
+	  (close down-in)
+	  (dup2 down-out 0)
+	  (dup2 up-in 1)
+	  (dup2 err-in 2)
+	  (apply execvp file args)
+	  (exit 1))
+	 (else 
+	  (close down-out)
+	  (close up-in)
+	  (close err-in)
+	  (list pid 
+		(make-fd-io-stream up-out down-in)
+		(make-fd-io-stream err-out err-out)))))))
+
+ (define (make-fd-io-stream in out)
+   (let ((write (lambda (bv start count) (fd-write out bv start count)))
+	 (read (lambda (bv start count) (fd-read in bv start count)))
+	 (closeit (lambda () (close in) (close out))))
+     (make-custom-binary-input/output-port
+      "fd-stream" read write #f #f closeit)))
+
+ (define write% (foreign-procedure "write" '(int ulong int) 'int))
+ (define (fd-write fd bytevector start count)
+   (write% fd 
+	   (+ (ffi/handle->address bytevector)
+	      bytevector-content-offset$
+	      start)
+	   count))
+
+ (define read% (foreign-procedure "read" '(int ulong int) 'int))
+ (define (fd-read fd bytevector start count)
+   ;;(printf "fd-read: ~a ~s ~a ~a\n" fd bytevector start count)
+   (read% fd 
+	  (+ (ffi/handle->address bytevector)
+	     bytevector-content-offset$
+	     start)
+	  count))
+
+ (define (make-server-socket port)
+   (let* ((args `("/bin/bash" "bash" 
+		  "-c" 
+		  ,(string-append
+		    "netcat -s 127.0.0.1 -q 0 -l -v "
+		    (if port 
+			(string-append "-p " (number->string port))
+			""))))
+	  (nc (apply start-process args))
+	  (err (transcoded-port (list-ref nc 2)
+				(make-transcoder (latin-1-codec))))
+	  (line (get-line err))
+	  (pos (last-index-of line '#\])))
+     (cond (pos
+	    (let* ((tail (substring line (+ pos 1) (string-length line)))
+		   (port (get-datum (open-string-input-port tail))))
+	      (list (car nc) (cadr nc) err port)))
+	   (#t (error "netcat failed: " line)))))
+
+ (define (accept socket codec)
+   (let* ((line (get-line (caddr socket)))
+	  (pos (last-index-of line #\])))
+     (cond (pos 
+	    (close-port (caddr socket))
+	    (let ((stream (cadr socket)))
+	      (let ((io (transcoded-port stream (make-transcoder codec))))
+		(values io io))))
+	   (else (error "accept failed: " line)))))
+
+ (define (local-port socket)
+   (list-ref socket 3))
+
+ (define (last-index-of str chr)
+   (let loop ((i (string-length str)))
+     (cond ((<= i 0) #f)
+	   (#t (let ((i (- i 1)))
+		 (cond ((char=? (string-ref str i) chr)
+			i)
+		       (#t 
+			(loop i))))))))
+
+ (define (close-socket socket)
+   ;;(close-port (cadr socket))
+   #f
+   )
+
+ )
+
+(library (swank sys)
+    (export implementation-name eval-in-interaction-environment)
+    (import (rnrs) 
+	    (primitives system-features
+			aeryn-evaluator))
+
+ (define (implementation-name) "larceny")
+
+ ;; see $LARCENY/r6rsmode.sch:
+ ;;   Larceny's ERR5RS and R6RS modes.
+ ;;   Code names:
+ ;;       Aeryn    ERR5RS
+ ;;       D'Argo   R6RS-compatible
+ ;;       Spanky   R6RS-conforming (not yet implemented)
+ (define (eval-in-interaction-environment form)
+   (aeryn-evaluator form))
+
+ )
+
+(import (rnrs) (rnrs eval) (larceny load))
+(load "swank-r6rs.scm")
+(eval '(start-server #f) (environment '(swank)))

sources_non_forked/slimv/slime/contrib/swank-listener-hooks.lisp

@@ -0,0 +1,91 @@
+;;; swank-listener-hooks.lisp --- listener with special hooks
+;;
+;; Author: Alan Ruttenberg  <alanr-l@mumble.net>
+
+;; Provides *slime-repl-eval-hooks* special variable which
+;; can be used for easy interception of SLIME REPL form evaluation
+;; for purposes such as integration with application event loop.
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (swank-require :swank-repl))
+
+(defvar *slime-repl-advance-history* nil
+  "In the dynamic scope of a single form typed at the repl, is set to nil to
+   prevent the repl from advancing the history - * ** *** etc.")
+
+(defvar *slime-repl-suppress-output* nil
+  "In the dynamic scope of a single form typed at the repl, is set to nil to
+   prevent the repl from printing the result of the evalation.")
+
+(defvar *slime-repl-eval-hook-pass* (gensym "PASS")
+  "Token to indicate that a repl hook declines to evaluate the form")
+
+(defvar *slime-repl-eval-hooks* nil
+  "A list of functions. When the repl is about to eval a form, first try running each of
+   these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass*
+   is considered a replacement for calling eval. If there are no hooks, or all
+   pass, then eval is used.")
+
+(export '*slime-repl-eval-hooks*)
+
+(defslimefun repl-eval-hook-pass ()
+  "call when repl hook declines to evaluate the form"
+  (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*))
+
+(defslimefun repl-suppress-output ()
+  "In the dynamic scope of a single form typed at the repl, call to
+   prevent the repl from printing the result of the evalation."
+  (setq *slime-repl-suppress-output* t))
+
+(defslimefun repl-suppress-advance-history ()
+  "In the dynamic scope of a single form typed at the repl, call to
+   prevent the repl from advancing the history - * ** *** etc."
+  (setq *slime-repl-advance-history* nil))
+
+(defun %eval-region (string)
+  (with-input-from-string (stream string)
+    (let (- values)
+      (loop
+       (let ((form (read stream nil stream)))
+	 (when (eq form stream)
+	   (fresh-line)
+	   (finish-output)
+	   (return (values values -)))
+	 (setq - form)
+	 (if *slime-repl-eval-hooks*
+	     (setq values (run-repl-eval-hooks form))
+	     (setq values (multiple-value-list (eval form))))
+	 (finish-output))))))
+
+(defun run-repl-eval-hooks (form)
+  (loop for hook in *slime-repl-eval-hooks*
+	for res =  (catch *slime-repl-eval-hook-pass*
+		     (multiple-value-list (funcall hook form)))
+	until (not (eq res *slime-repl-eval-hook-pass*))
+	finally (return
+		  (if (eq res *slime-repl-eval-hook-pass*)
+		      (multiple-value-list (eval form))
+		      res))))
+
+(defun %listener-eval (string)
+  (clear-user-input)
+  (with-buffer-syntax ()
+    (swank-repl::track-package
+     (lambda ()
+       (let ((*slime-repl-suppress-output* :unset)
+	     (*slime-repl-advance-history* :unset))
+	 (multiple-value-bind (values last-form) (%eval-region string)
+	   (unless (or (and (eq values nil) (eq last-form nil))
+		       (eq *slime-repl-advance-history* nil))
+	     (setq *** **  ** *  * (car values)
+		   /// //  // /  / values))
+	   (setq +++ ++  ++ +  + last-form)
+	   (unless (eq *slime-repl-suppress-output* t)
+	     (funcall swank-repl::*send-repl-results-function* values)))))))
+  nil)
+
+(setq swank-repl::*listener-eval-function* '%listener-eval)
+
+(provide :swank-listener-hooks)

sources_non_forked/slimv/slime/contrib/swank-macrostep.lisp

@@ -0,0 +1,227 @@
+;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el
+;;
+;; Authors: Luis Oliveira <luismbo@gmail.com>
+;;          Jon Oddie <j.j.oddie@gmail.com>
+;;
+;; License: Public Domain
+
+(defpackage swank-macrostep
+  (:use cl swank)
+  (:import-from swank
+		#:*macroexpand-printer-bindings*
+                #:with-buffer-syntax
+		#:with-bindings
+                #:to-string
+                #:macroexpand-all
+                #:compiler-macroexpand-1
+                #:defslimefun
+                #:collect-macro-forms)
+  (:export #:macrostep-expand-1
+           #:macro-form-p))
+
+(in-package #:swank-macrostep)
+
+(defslimefun macrostep-expand-1 (string compiler-macros? context)
+  (with-buffer-syntax ()
+    (let ((form (read-from-string string)))
+      (multiple-value-bind (expansion error-message)
+	  (expand-form-once form compiler-macros? context)
+	(if error-message
+            `(:error ,error-message)
+	    (multiple-value-bind (macros compiler-macros)
+		(collect-macro-forms-in-context expansion context)
+	      (let* ((all-macros (append macros compiler-macros))
+		     (pretty-expansion (pprint-to-string expansion))
+		     (positions (collect-form-positions expansion
+							pretty-expansion
+							all-macros))
+                     (subform-info
+                      (loop
+                         for form in all-macros
+                         for (start end) in positions
+                         when (and start end)
+                         collect (let ((op-name (to-string (first form)))
+                                       (op-type
+                                        (if (member form macros)
+                                            :macro
+                                            :compiler-macro)))
+                                   (list op-name
+                                         op-type
+                                         start)))))
+		`(:ok ,pretty-expansion ,subform-info))))))))
+
+(defun expand-form-once (form compiler-macros? context)
+  (multiple-value-bind (expansion expanded?)
+      (macroexpand-1-in-context form context)
+    (if expanded?
+	(values expansion nil)
+	(if (not compiler-macros?)
+	    (values nil "Not a macro form")
+	    (multiple-value-bind (expansion expanded?)
+		(compiler-macroexpand-1 form)
+	      (if expanded?
+		  (values expansion nil)
+		  (values nil "Not a macro or compiler-macro form")))))))
+
+(defslimefun macro-form-p (string compiler-macros? context)
+  (with-buffer-syntax ()
+    (let ((form
+           (handler-case
+               (read-from-string string)
+             (error (condition)
+               (unless (debug-on-swank-error)
+                 (return-from macro-form-p
+                   `(:error ,(format nil "Read error: ~A" condition))))))))
+      `(:ok ,(macro-form-type form compiler-macros? context)))))
+
+(defun macro-form-type (form compiler-macros? context)
+  (cond
+    ((or (not (consp form))
+         (not (symbolp (car form))))
+     nil)
+    ((multiple-value-bind (expansion expanded?)
+         (macroexpand-1-in-context form context)
+       (declare (ignore expansion))
+       expanded?)
+     :macro)
+    ((and compiler-macros?
+          (multiple-value-bind (expansion expanded?)
+              (compiler-macroexpand-1 form)
+            (declare (ignore expansion))
+            expanded?))
+     :compiler-macro)
+    (t
+     nil)))
+
+
+;;;; Hacks to support macro-expansion within local context
+
+(defparameter *macrostep-tag* (gensym))
+
+(defparameter *macrostep-placeholder* '*macrostep-placeholder*)
+
+(define-condition expansion-in-context-failed (simple-error)
+  ())
+
+(defmacro throw-expansion (form &environment env)
+  (throw *macrostep-tag* (macroexpand-1 form env)))
+
+(defmacro throw-collected-macro-forms (form &environment env)
+  (throw *macrostep-tag* (collect-macro-forms form env)))
+
+(defun macroexpand-1-in-context (form context)
+  (handler-case
+      (macroexpand-and-catch
+       `(throw-expansion ,form) context)
+    (error ()
+      (macroexpand-1 form))))
+
+(defun collect-macro-forms-in-context (form context)
+  (handler-case
+      (macroexpand-and-catch
+       `(throw-collected-macro-forms ,form) context)
+    (error ()
+      (collect-macro-forms form))))
+
+(defun macroexpand-and-catch (form context)
+  (catch *macrostep-tag*
+    (macroexpand-all (enclose-form-in-context form context))
+    (error 'expansion-in-context-failed)))
+
+(defun enclose-form-in-context (form context)
+  (with-buffer-syntax ()
+    (destructuring-bind (prefix suffix) context
+      (let* ((placeholder-form
+              (read-from-string
+               (concatenate
+                'string
+                prefix (prin1-to-string *macrostep-placeholder*) suffix)))
+             (substituted-form (subst form *macrostep-placeholder*
+                                      placeholder-form)))
+        (if (not (equal placeholder-form substituted-form))
+            substituted-form
+            (error 'expansion-in-context-failed))))))
+
+
+;;;; Tracking Pretty Printer
+
+(defun marker-char-p (char)
+  (<= #xe000 (char-code char) #xe8ff))
+
+(defun make-marker-char (id)
+  ;; using the private-use characters U+E000..U+F8FF as markers, so
+  ;; that's our upper limit for how many we can use.
+  (assert (<= 0 id #x8ff))
+  (code-char (+ #xe000 id)))
+
+(defun marker-char-id (char)
+  (assert (marker-char-p char))
+  (- (char-code char) #xe000))
+
+(defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32)))
+
+(defun whitespacep (char)
+  (member char +whitespace+))
+
+(defun pprint-to-string (object &optional pprint-dispatch)
+  (let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*)))
+    (with-bindings *macroexpand-printer-bindings*
+      (to-string object))))
+
+#-clisp
+(defun collect-form-positions (expansion printed-expansion forms)
+  (loop for (start end)
+     in (collect-marker-positions
+         (pprint-to-string expansion (make-tracking-pprint-dispatch forms))
+         (length forms))
+     collect (when (and start end)
+               (list (find-non-whitespace-position printed-expansion start)
+                     (find-non-whitespace-position printed-expansion end)))))
+
+;; The pprint-dispatch table constructed by
+;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack
+;; overflow under CLISP version 2.49.  Make the COLLECT-FORM-POSITIONS
+;; entry point a no-op in thi case, so that basic macro-expansion will
+;; still work (without detection of inner macro forms)
+#+clisp
+(defun collect-form-positions (expansion printed-expansion forms)
+  nil)
+
+(defun make-tracking-pprint-dispatch (forms)
+  (let ((original-table *print-pprint-dispatch*)
+        (table (copy-pprint-dispatch)))
+    (flet ((maybe-write-marker (position stream)
+             (when position
+               (write-char (make-marker-char position) stream))))
+      (set-pprint-dispatch 'cons
+                           (lambda (stream cons)
+                             (let ((pos (position cons forms)))
+                               (maybe-write-marker pos stream)
+                               ;; delegate printing to the original table.
+                               (funcall (pprint-dispatch cons original-table)
+                                        stream
+                                        cons)
+                               (maybe-write-marker pos stream)))
+                           most-positive-fixnum
+                           table))
+    table))
+
+(defun collect-marker-positions (string position-count)
+  (let ((positions (make-array position-count :initial-element nil)))
+    (loop with p = 0
+          for char across string
+          unless (whitespacep char)
+            do (if (marker-char-p char)
+                   (push p (aref positions (marker-char-id char)))
+                   (incf p)))
+    (map 'list #'reverse positions)))
+
+(defun find-non-whitespace-position (string position)
+  (loop with non-whitespace-position = -1
+        for i from 0 and char across string
+        unless (whitespacep char)
+          do (incf non-whitespace-position)
+        until (eql non-whitespace-position position)
+        finally (return i)))
+
+(provide :swank-macrostep)

sources_non_forked/slimv/slime/contrib/swank-media.lisp

@@ -0,0 +1,25 @@
+;;; swank-media.lisp --- insert other media (images)
+;;
+;; Authors: Christophe Rhodes <csr21@cantab.net>
+;;
+;; Licence: GPLv2 or later
+;;
+
+(in-package :swank)
+
+;; this file is empty of functionality.  The slime-media contrib
+;; allows swank to return messages other than :write-string as repl
+;; results; this is used in the R implementation of swank to display R
+;; objects with graphical representations (such as trellis objects) as
+;; image presentations in the swank repl.  In R, this is done by
+;; having a hook function for the preparation of the repl results, in
+;; addition to the already-existing hook for sending the repl results
+;; (*send-repl-results-function*, used by swank-presentations.lisp).
+;; The swank-media.R contrib implementation defines a generic function
+;; for use as this hook, along with methods for commonly-encountered
+;; graphical R objects.  (This strategy is harder in CL, where methods
+;; can only be defined if their specializers already exist; in R's S3
+;; object system, methods are ordinary functions with a special naming
+;; convention)
+
+(provide :swank-media)

sources_non_forked/slimv/slime/contrib/swank-mit-scheme.scm

@@ -0,0 +1,883 @@
+;;; swank-mit-scheme.scm --- SLIME server for MIT Scheme
+;;
+;; Copyright (C) 2008  Helmut Eller
+;;
+;; This file is licensed under the terms of the GNU General Public
+;; License as distributed with Emacs (press C-h C-c for details).
+
+;;;; Installation:
+#|
+
+1. You need MIT Scheme 9.2
+
+2. The Emacs side needs some fiddling.  I have the following in
+   my .emacs:
+
+(setq slime-lisp-implementations
+      '((mit-scheme ("mit-scheme") :init mit-scheme-init)))
+
+(defun mit-scheme-init (file encoding)
+  (format "%S\n\n"
+	  `(begin
+	    (load-option 'format)
+	    (load-option 'sos)
+	    (eval 
+	     '(create-package-from-description
+	       (make-package-description '(swank) (list (list))
+					 (vector) (vector) (vector) false))
+	     (->environment '(package)))
+	    (load ,(expand-file-name 
+		    ".../contrib/swank-mit-scheme.scm" ; <-- insert your path
+		    slime-path)
+		  (->environment '(swank)))
+	    (eval '(start-swank ,file) (->environment '(swank))))))
+
+(defun mit-scheme ()
+  (interactive)
+  (slime 'mit-scheme))
+
+(defun find-mit-scheme-package ()
+  (save-excursion
+    (let ((case-fold-search t))
+      (and (re-search-backward "^[;]+ package: \\((.+)\\).*$" nil t)
+	   (match-string-no-properties 1)))))
+
+(setq slime-find-buffer-package-function 'find-mit-scheme-package)
+(add-hook 'scheme-mode-hook (lambda () (slime-mode 1)))
+
+   The `mit-scheme-init' function first loads the SOS and FORMAT
+   libraries, then creates a package "(swank)", and loads this file
+   into that package.  Finally it starts the server.  
+
+   `find-mit-scheme-package' tries to figure out which package the
+   buffer belongs to, assuming that ";;; package: (FOO)" appears
+   somewhere in the file.  Luckily, this assumption is true for many of
+   MIT Scheme's own files.  Alternatively, you could add Emacs style
+   -*- slime-buffer-package: "(FOO)" -*- file variables.
+
+4. Start everything with `M-x mit-scheme'.
+
+|#
+
+;;; package: (swank)
+
+;; Modified for Slimv:
+;; - load options
+;; - remove extension in compile-file-for-emacs
+(load-option 'format)
+(load-option 'sos)
+
+(if (< (car (get-subsystem-version "Release"))
+       '9)
+    (error "This file requires MIT Scheme Release 9"))
+
+(define (swank port)
+  (accept-connections (or port 4005) #f))
+
+;; ### hardcoded port number for now.  netcat-openbsd doesn't print
+;; the listener port anymore.
+(define (start-swank port-file)
+  (accept-connections 4055 port-file) 
+  )
+
+;;;; Networking
+
+(define (accept-connections port port-file)
+  (let ((sock (open-tcp-server-socket port (host-address-loopback))))
+    (format #t "Listening on port: ~s~%" port)
+    (if port-file (write-port-file port port-file))
+    (dynamic-wind 
+	(lambda () #f)
+	(lambda () (serve (tcp-server-connection-accept sock #t #f)))
+	(lambda () (close-tcp-server-socket sock)))))
+
+(define (write-port-file portnumber filename)
+  (call-with-output-file filename (lambda (p) (write portnumber p))))
+
+(define *top-level-restart* #f)
+(define (serve socket)
+  (with-simple-restart 
+      'disconnect "Close connection."
+      (lambda ()
+	(with-keyboard-interrupt-handler 
+	    (lambda () (main-loop socket))))))
+
+(define (disconnect) 
+  (format #t "Disconnecting ...~%")
+  (invoke-restart (find-restart 'disconnect)))
+
+(define (main-loop socket)
+  (do () (#f)
+    (with-simple-restart 
+	'abort "Return to SLIME top-level."
+	(lambda () 
+	  (fluid-let ((*top-level-restart* (find-restart 'abort)))
+	    (dispatch (read-packet socket) socket 0))))))
+
+(define (with-keyboard-interrupt-handler fun)
+  (define (set-^G-handler exp)
+    (eval `(vector-set! keyboard-interrupt-vector (char->integer #\G) ,exp)
+	  (->environment '(runtime interrupt-handler))))
+  (dynamic-wind
+      (lambda () #f)
+      (lambda ()
+	(set-^G-handler
+	 `(lambda (char) (with-simple-restart
+			  'continue "Continue from interrupt."
+			  (lambda () (error "Keyboard Interrupt.")))))
+	(fun))
+      (lambda ()
+	(set-^G-handler '^G-interrupt-handler))))
+
+
+;;;; Reading/Writing of SLIME packets
+
+(define (read-packet in)
+  "Read an S-expression from STREAM using the SLIME protocol."
+  (let* ((len (read-length in))
+	 (buffer (make-string len)))
+    (fill-buffer! in buffer)
+    (read-from-string buffer)))
+
+(define (write-packet message out)
+  (let* ((string (write-to-string message)))
+    (log-event "WRITE: [~a]~s~%" (string-length string) string)
+    (write-length (string-length string) out)
+    (write-string string out)
+    (flush-output out)))
+
+(define (fill-buffer! in buffer)
+  (read-string! buffer in))
+
+(define (read-length in)
+  (if (eof-object? (peek-char in)) (disconnect))
+  (do ((len 6 (1- len))
+       (sum 0 (+ (* sum 16) (char->hex-digit (read-char in)))))
+      ((zero? len) sum)))
+
+(define (ldb size position integer)
+  "LoaD a Byte of SIZE bits at bit position POSITION from INTEGER."
+  (fix:and (fix:lsh integer (- position))
+	   (1- (fix:lsh 1 size))))
+
+(define (write-length len out)
+  (do ((pos 20 (- pos 4)))
+      ((< pos 0))
+    (write-hex-digit (ldb 4 pos len) out)))
+
+(define (write-hex-digit n out)
+  (write-char (hex-digit->char n) out))
+
+(define (hex-digit->char n)
+  (digit->char n 16))
+
+(define (char->hex-digit c)
+  (char->digit c 16))
+
+
+;;;; Event dispatching
+
+(define (dispatch request socket level)
+  (log-event "READ: ~s~%" request)
+  (case (car request)
+    ((:emacs-rex) (apply emacs-rex socket level (cdr request)))))
+
+(define (swank-package)
+  (if (name->package '(swank))
+      '(swank)
+      '(user)))
+
+(define *buffer-package* #f)
+(define (find-buffer-package name)
+  (if (elisp-false? name)
+      #f
+      (let ((v (ignore-errors 
+		(lambda () (name->package (read-from-string name))))))
+	(and (package? v) v))))
+
+(define swank-env (->environment (swank-package)))
+(define (user-env buffer-package)
+  (cond ((string? buffer-package)
+	 (let ((p (find-buffer-package buffer-package)))
+	   (if (not p) (error "Invalid package name: " buffer-package))
+	   (package/environment p)))
+	(else (nearest-repl/environment))))
+
+;; quote keywords
+(define (hack-quotes list)
+  (map (lambda (x)
+	 (cond ((symbol? x) `(quote ,x))
+	       (#t x)))
+       list))
+
+(define (emacs-rex socket level sexp package thread id)
+  (let ((ok? #f) (result #f) (condition #f))
+    (dynamic-wind
+	(lambda () #f)
+	(lambda ()
+	  (bind-condition-handler 
+	   (list condition-type:serious-condition)
+	   (lambda (c) (set! condition c) (invoke-sldb socket (1+ level) c))
+	   (lambda ()
+	     (fluid-let ((*buffer-package* package))
+	       (set! result 
+		     (eval (cons* (car sexp) socket (hack-quotes (cdr sexp)))
+			   swank-env))
+	       (set! ok? #t)))))
+	(lambda ()
+	  (write-packet `(:return 
+			  ,(if ok? `(:ok ,result)
+			       `(:abort 
+				 ,(if condition 
+				      (format #f "~a"
+					      (condition/type condition))
+				      "<unknown reason>")))
+			  ,id)
+			 socket)))))
+
+(define (swank:connection-info _)
+  (let ((p (environment->package (user-env #f))))
+    `(:pid ,(unix/current-pid)
+      :package (:name ,(write-to-string (package/name p))
+		      :prompt ,(write-to-string (package/name p)))
+      :lisp-implementation 
+      (:type "MIT Scheme" :version ,(get-subsystem-version-string "release"))
+      :encoding (:coding-systems ("iso-8859-1"))
+      )))
+
+(define (swank:quit-lisp _)
+  (%exit))
+
+
+;;;; Evaluation
+
+(define (swank-repl:listener-eval socket string)
+  ;;(call-with-values (lambda () (eval-region string socket))
+  ;;  (lambda values `(:values . ,(map write-to-string values))))
+  `(:values ,(write-to-string (eval-region string socket))))
+
+(define (eval-region string socket)
+  (let ((sexp (read-from-string string)))
+    (if (eof-object? exp)
+	(values)
+	(with-output-to-repl socket
+	  (lambda () (eval sexp (user-env *buffer-package*)))))))
+
+(define (with-output-to-repl socket fun)
+  (let ((p (make-port repl-port-type socket)))
+    (dynamic-wind
+	(lambda () #f)
+	(lambda () (with-output-to-port p fun))
+	(lambda () (flush-output p)))))
+
+(define (swank:interactive-eval socket string)
+  ;;(call-with-values (lambda () (eval-region string)) format-for-echo-area)
+  (format-values (eval-region string socket))
+  )
+
+(define (format-values . values)
+  (if (null? values) 
+      "; No value"
+      (with-string-output-port
+	  (lambda (out)
+	    (write-string "=> " out)
+	    (do ((vs values (cdr vs))) ((null? vs))
+	      (write (car vs) out)
+	      (if (not (null? (cdr vs)))
+		  (write-string ", " out)))))))
+
+(define (swank:pprint-eval _ string)
+  (pprint-to-string (eval (read-from-string string) 
+			  (user-env *buffer-package*))))
+
+(define (swank:interactive-eval-region socket string)
+  (format-values (eval-region string socket)))
+
+(define (swank:set-package _ package)
+  (set-repl/environment! (nearest-repl) 
+			 (->environment (read-from-string package)))
+  (let* ((p (environment->package (user-env #f)))
+	 (n (write-to-string (package/name p))))
+    (list n n)))
+
+ 
+(define (repl-write-substring port string start end)
+  (cond ((< start end)
+	 (write-packet `(:write-string ,(substring string start end))
+		       (port/state port))))
+  (- end start))
+
+(define (repl-write-char port char)
+  (write-packet `(:write-string ,(string char))
+                (port/state port)))
+
+(define repl-port-type
+  (make-port-type `((write-substring ,repl-write-substring)
+		    (write-char ,repl-write-char)) #f))
+
+(define (swank-repl:create-repl socket . _)
+  (let* ((env (user-env #f))
+	 (name (format #f "~a" (package/name (environment->package env)))))
+    (list name name)))
+
+
+;;;; Compilation
+
+(define (swank:compile-string-for-emacs _ string . x)
+  (apply 
+   (lambda (errors seconds)
+     `(:compilation-result ,errors t ,seconds nil nil))
+   (call-compiler
+    (lambda ()
+      (let* ((sexps (snarf-string string))
+	     (env (user-env *buffer-package*))
+	     (scode (syntax `(begin ,@sexps) env))
+	     (compiled-expression (compile-scode scode #t)))
+	(scode-eval compiled-expression env))))))
+
+(define (snarf-string string)
+  (with-input-from-string string
+    (lambda () 
+      (let loop ()
+	(let ((e (read)))
+	  (if (eof-object? e) '() (cons e (loop))))))))
+
+(define (call-compiler fun)
+  (let ((time #f))
+    (with-timings fun
+      (lambda (run-time gc-time real-time)
+	(set! time real-time)))
+    (list 'nil (internal-time/ticks->seconds time))))
+
+(define (swank:compiler-notes-for-emacs _) nil)
+
+(define (swank:compile-file-for-emacs socket file load?)
+  (apply
+   (lambda (errors seconds)
+     (list ':compilation-result errors 't seconds load? 
+	   (->namestring (pathname-name file))))
+   (call-compiler
+    (lambda () (with-output-to-repl socket (lambda () (compile-file file)))))))
+
+(define (swank:load-file socket file)
+  (with-output-to-repl socket
+    (lambda () 
+      (pprint-to-string 
+       (load file (user-env *buffer-package*))))))
+
+(define (swank:disassemble-form _ string)
+  (let ((sexp (let ((sexp (read-from-string string)))
+		(cond ((and (pair? sexp) (eq? (car sexp) 'quote))
+		       (cadr sexp))
+		      (#t sexp)))))
+    (with-output-to-string
+      (lambda () 
+	(compiler:disassemble
+	 (eval sexp (user-env *buffer-package*)))))))
+
+(define (swank:disassemble-symbol _ string)
+  (with-output-to-string
+      (lambda () 
+	(compiler:disassemble
+	 (eval (read-from-string string) 
+	       (user-env *buffer-package*))))))
+
+
+;;;; Macroexpansion
+
+(define (swank:swank-macroexpand-all _ string) 
+  (with-output-to-string
+      (lambda ()
+	(pp (syntax (read-from-string string)
+		    (user-env *buffer-package*))))))
+(define swank:swank-macroexpand-1 swank:swank-macroexpand-all)
+(define swank:swank-macroexpand swank:swank-macroexpand-all)
+
+
+;;; Arglist
+
+(define (swank:operator-arglist socket name pack)
+  (let ((v (ignore-errors
+	    (lambda ()
+              (string-trim-right
+               (with-output-to-string
+                 (lambda ()
+                   (carefully-pa
+                    (eval (read-from-string name) (user-env pack))))))))))
+    (if (condition? v) 'nil v)))
+
+(define (carefully-pa o)
+  (cond ((arity-dispatched-procedure? o) 
+	 ;; MIT Scheme crashes for (pa /)
+	 (display "arity-dispatched-procedure"))
+	((procedure? o) (pa o))
+	(else (error "Not a procedure"))))
+
+
+;;; Some unimplemented stuff.
+(define (swank:buffer-first-change . _) nil)
+(define (swank:filename-to-modulename . _) nil)
+(define (swank:swank-require . _) nil)
+
+;; M-. is beyond my capabilities.
+(define (swank:find-definitions-for-emacs . _) nil)
+
+
+;;; Debugger
+
+(define-structure (sldb-state (conc-name sldb-state.)) condition restarts)
+
+(define *sldb-state* #f)
+(define (invoke-sldb socket level condition)
+  (fluid-let ((*sldb-state* (make-sldb-state condition (bound-restarts))))
+    (dynamic-wind 
+	(lambda () #f)
+	(lambda ()
+	  (write-packet `(:debug 0 ,level ,@(sldb-info *sldb-state* 0 20))
+			socket)
+	  (sldb-loop level socket))
+	(lambda ()
+	  (write-packet `(:debug-return 0 ,level nil) socket)))))
+
+(define (sldb-loop level socket)
+  (write-packet `(:debug-activate 0 ,level) socket)
+  (with-simple-restart 
+      'abort (format #f "Return to SLDB level ~a." level)
+      (lambda () (dispatch (read-packet socket) socket level)))
+  (sldb-loop level socket))
+
+(define (sldb-info state start end)
+  (let ((c (sldb-state.condition state))
+	(rs (sldb-state.restarts state)))
+    (list (list (condition/report-string c)
+		(format #f "  [~a]" (%condition-type/name (condition/type c)))
+		nil)
+	  (sldb-restarts rs)
+	  (sldb-backtrace c start end)
+	  ;;'((0 "dummy frame"))
+	  '())))
+
+(define %condition-type/name
+  (eval '%condition-type/name (->environment '(runtime error-handler))))
+
+(define (sldb-restarts restarts)
+  (map (lambda (r) 
+	 (list (symbol->string (restart/name r))
+	       (with-string-output-port 
+		(lambda (p) (write-restart-report r p)))))
+       restarts))
+
+(define (swank:throw-to-toplevel . _)
+  (invoke-restart *top-level-restart*))
+
+(define (swank:sldb-abort . _)
+  (abort (sldb-state.restarts *sldb-state*)))
+
+(define (swank:sldb-continue . _)
+  (continue (sldb-state.restarts *sldb-state*)))
+
+(define (swank:invoke-nth-restart-for-emacs _ _sldb-level n)
+  (invoke-restart (list-ref (sldb-state.restarts *sldb-state*) n)))
+
+(define (swank:debugger-info-for-emacs _ from to)
+  (sldb-info *sldb-state* from to))
+
+(define (swank:backtrace _ from to)
+  (sldb-backtrace (sldb-state.condition *sldb-state*) from to))
+
+(define (sldb-backtrace condition from to)
+  (sldb-backtrace-aux (condition/continuation condition) from to))
+
+(define (sldb-backtrace-aux k from to)
+  (let ((l (map frame>string (substream (continuation>frames k) from to))))
+    (let loop ((i from) (l l))
+      (if (null? l)
+	  '()
+	  (cons (list i (car l)) (loop (1+ i) (cdr l)))))))
+
+;; Stack parser fails for this:
+;; (map (lambda (x) x) "/tmp/x.x")
+
+(define (continuation>frames k)
+  (let loop ((frame (continuation->stack-frame k)))
+    (cond ((not frame)	(stream))
+	  (else
+	   (let ((next (ignore-errors
+			(lambda () (stack-frame/next-subproblem frame)))))
+	     (cons-stream frame
+			  (if (condition? next) 
+			      (stream next) 
+			      (loop next))))))))
+
+(define (frame>string frame)
+  (if (condition? frame)
+      (format #f "Bogus frame: ~a ~a" frame
+	      (condition/report-string frame))
+      (with-string-output-port (lambda (p) (print-frame frame p)))))
+
+(define (print-frame frame port)
+  (define (invalid-subexpression? subexpression)
+    (or (debugging-info/undefined-expression? subexpression)
+	(debugging-info/unknown-expression? subexpression)))
+  (define (invalid-expression? expression)
+    (or (debugging-info/undefined-expression? expression)
+	(debugging-info/compiled-code? expression)))
+  (with-values (lambda () (stack-frame/debugging-info frame))
+    (lambda (expression environment subexpression)
+      (cond ((debugging-info/compiled-code? expression)
+	     (write-string ";unknown compiled code" port))
+	    ((not (debugging-info/undefined-expression? expression))
+	     (fluid-let ((*unparse-primitives-by-name?* #t))
+	       (write
+		(unsyntax (if (invalid-subexpression? subexpression)
+			      expression
+			      subexpression))
+		port)))
+	    ((debugging-info/noise? expression)
+	     (write-string ";" port)
+	     (write-string ((debugging-info/noise expression) #f)
+			   port))
+	    (else
+	     (write-string ";undefined expression" port))))))
+
+(define (substream s from to)
+  (let loop ((i 0) (l '()) (s s))
+    (cond ((or (= i to) (stream-null? s)) (reverse l))
+	  ((< i from) (loop (1+ i) l (stream-cdr s)))
+	  (else (loop (1+ i) (cons (stream-car s) l) (stream-cdr s))))))
+
+(define (swank:frame-locals-and-catch-tags _ frame)
+  (list (map frame-var>elisp (frame-vars (sldb-get-frame frame)))
+	'()))
+  
+(define (frame-vars frame)
+  (with-values (lambda () (stack-frame/debugging-info frame))
+    (lambda (expression environment subexpression)
+      (cond ((environment? environment)
+	     (environment>frame-vars environment))
+	    (else '())))))
+
+(define (environment>frame-vars environment)
+  (let loop ((e environment))
+    (cond ((environment->package e) '())
+	  (else (append (environment-bindings e)
+			(if (environment-has-parent? e)
+			    (loop (environment-parent e))
+			    '()))))))
+
+(define (frame-var>elisp b)
+  (list ':name (write-to-string (car b))
+	':value (cond ((null? (cdr b)) "{unavailable}")
+		      (else (>line (cadr b))))
+	':id 0))
+
+(define (sldb-get-frame index)
+  (stream-ref (continuation>frames 
+	       (condition/continuation 
+		(sldb-state.condition *sldb-state*)))
+	      index))
+
+(define (frame-var-value frame var)
+  (let ((binding (list-ref (frame-vars frame) var)))
+    (cond ((cdr binding) (cadr binding))
+	  (else unspecific))))
+
+(define (swank:inspect-frame-var _ frame var)
+  (reset-inspector)
+  (inspect-object (frame-var-value (sldb-get-frame frame) var)))
+
+
+;;;; Completion
+
+(define (swank:simple-completions _ string package)
+  (let ((strings (all-completions string (user-env package) string-prefix?)))
+    (list (sort strings string<?)
+	  (longest-common-prefix strings))))
+
+(define (all-completions pattern env match?)
+  (let ((ss (map %symbol->string (environment-names env))))
+    (keep-matching-items ss (lambda (s) (match? pattern s)))))
+
+;; symbol->string is too slow
+(define %symbol->string symbol-name)
+
+(define (environment-names env)
+  (append (environment-bound-names env)
+	  (if (environment-has-parent? env)
+	      (environment-names (environment-parent env))
+	      '())))
+
+(define (longest-common-prefix strings)
+  (define (common-prefix s1 s2)
+    (substring s1 0 (string-match-forward s1 s2)))
+  (reduce common-prefix "" strings))
+
+
+;;;; Apropos
+
+(define (swank:apropos-list-for-emacs _ name #!optional 
+				      external-only case-sensitive package)
+  (let* ((pkg (and (string? package)
+		   (find-package (read-from-string package))))
+	 (parent (and (not (default-object? external-only))
+		      (elisp-false? external-only)))
+	 (ss  (append-map (lambda (p)
+			    (map (lambda (s) (cons p s))
+				 (apropos-list name p (and pkg parent))))
+			  (if pkg (list pkg) (all-packages))))
+	 (ss (sublist ss 0 (min (length ss) 200))))
+    (map (lambda (e)
+	   (let ((p (car e)) (s (cdr e)))
+	     (list ':designator (format #f "~a ~a" s (package/name p))
+		   ':variable (>line
+			       (ignore-errors
+				(lambda () (package-lookup p s)))))))
+	 ss)))
+
+(define (swank:list-all-package-names . _)
+  (map (lambda (p) (write-to-string (package/name p)))
+       (all-packages)))
+
+(define (all-packages)
+  (define (package-and-children package)
+    (append (list package)
+	    (append-map package-and-children (package/children package))))
+  (package-and-children system-global-package))
+
+
+;;;; Inspector
+
+(define-structure (inspector-state (conc-name istate.))
+  object parts next previous content)
+
+(define istate #f)
+
+(define (reset-inspector)
+  (set! istate #f))
+
+(define (swank:init-inspector _ string)
+  (reset-inspector)
+  (inspect-object (eval (read-from-string string) 
+			(user-env *buffer-package*))))
+
+(define (inspect-object o)
+  (let ((previous istate)
+	(content (inspect o))
+	(parts (make-eqv-hash-table)))
+    (set! istate (make-inspector-state o parts #f previous content))
+    (if previous (set-istate.next! previous istate))
+    (istate>elisp istate)))
+
+(define (istate>elisp istate)
+  (list ':title (>line (istate.object istate))
+	':id (assign-index (istate.object istate) (istate.parts istate))
+	':content (prepare-range (istate.parts istate)
+				 (istate.content istate)
+				 0 500)))
+
+(define (assign-index o parts)
+  (let ((i (hash-table/count parts)))
+    (hash-table/put! parts i o)
+    i))
+
+(define (prepare-range parts content from to)
+  (let* ((cs (substream content from to))
+	 (ps (prepare-parts cs parts)))
+    (list ps
+	  (if (< (length cs) (- to from))
+	      (+ from (length cs))
+	      (+ to 1000))
+	  from to)))
+
+(define (prepare-parts ps parts)
+  (define (line label value)
+    `(,(format #f "~a: " label)
+      (:value ,(>line value) ,(assign-index value parts))
+      "\n"))
+  (append-map (lambda (p)
+		(cond ((string? p) (list p))
+		      ((symbol? p) (list (symbol->string p)))
+		      (#t
+		       (case (car p)
+			 ((line) (apply line (cdr p)))
+			 (else (error "Invalid part:" p))))))
+	      ps))
+
+(define (swank:inspect-nth-part _ index)
+  (inspect-object (hash-table/get (istate.parts istate) index 'no-such-part)))
+
+(define (swank:quit-inspector _)
+  (reset-inspector))
+
+(define (swank:inspector-pop _)
+  (cond ((istate.previous istate)
+	 (set! istate (istate.previous istate))
+	 (istate>elisp istate))
+	(else 'nil)))
+
+(define (swank:inspector-next _)
+  (cond ((istate.next istate)
+	 (set! istate (istate.next istate))
+	 (istate>elisp istate))
+	(else 'nil)))
+
+(define (swank:inspector-range _ from to)
+  (prepare-range (istate.parts istate)
+		 (istate.content istate)
+		 from to))
+
+(define-syntax stream*
+  (syntax-rules ()
+    ((stream* tail) tail)
+    ((stream* e1 e2 ...) (cons-stream e1 (stream* e2 ...)))))
+
+(define (iline label value) `(line ,label ,value))
+
+(define-generic inspect (o))
+
+(define-method inspect ((o <object>))
+  (cond ((environment? o) (inspect-environment o))
+	((vector? o) (inspect-vector o))
+	((procedure? o) (inspect-procedure o))
+	((compiled-code-block? o) (inspect-code-block o))
+	;;((system-pair? o) (inspect-system-pair o))
+	((probably-scode? o) (inspect-scode o))
+	(else (inspect-fallback o))))
+
+(define (inspect-fallback o)
+  (let* ((class (object-class o))
+	 (slots (class-slots class)))
+    (stream*
+     (iline "Class" class)
+     (let loop ((slots slots))
+       (cond ((null? slots) (stream))
+	     (else
+	      (let ((n (slot-name (car slots))))
+		(stream* (iline n (slot-value o n))
+			 (loop (cdr slots))))))))))
+
+(define-method inspect ((o <pair>))
+  (if (or (pair? (cdr o)) (null? (cdr o)))
+      (inspect-list o)
+      (inspect-cons o)))
+
+(define (inspect-cons o)
+  (stream (iline "car" (car o))
+	  (iline "cdr" (cdr o))))
+
+(define (inspect-list o)
+  (let loop ((i 0) (o o))
+    (cond ((null? o) (stream))
+	  ((or (pair? (cdr o)) (null? (cdr o)))
+	   (stream* (iline i (car o))
+		    (loop (1+ i) (cdr o))))
+	  (else 
+	   (stream (iline i (car o))
+		   (iline "tail" (cdr o)))))))
+
+(define (inspect-environment o)
+  (stream*
+   (iline "(package)" (environment->package o))
+   (let loop ((bs (environment-bindings o)))
+     (cond ((null? bs)
+	    (if (environment-has-parent? o) 
+		(stream (iline "(<parent>)" (environment-parent o)))
+		(stream)))
+	   (else 
+	    (let* ((b (car bs)) (s (car b)))
+	      (cond ((null? (cdr b))
+		     (stream* s " {" (environment-reference-type o s) "}\n"
+			      (loop (cdr bs))))
+		    (else 
+		     (stream* (iline s (cadr b))
+			      (loop (cdr bs)))))))))))
+
+(define (inspect-vector o)
+  (let ((len (vector-length o)))
+    (let loop ((i 0))
+      (cond ((= i len) (stream))
+	    (else (stream* (iline i (vector-ref o i))
+			   (loop (1+ i))))))))
+
+(define (inspect-procedure o)
+  (cond ((primitive-procedure? o)
+	 (stream (iline "name" (primitive-procedure-name o))
+		 (iline "arity" (primitive-procedure-arity o))
+		 (iline "doc" (primitive-procedure-documentation o))))
+	((compound-procedure? o)
+	 (stream (iline "arity" (procedure-arity o))
+		 (iline "lambda" (procedure-lambda o))
+		 (iline "env" (ignore-errors
+			       (lambda () (procedure-environment o))))))
+	(else
+	 (stream
+	  (iline "block" (compiled-entry/block o))
+	  (with-output-to-string (lambda () (compiler:disassemble o)))))))
+
+(define (inspect-code-block o)
+  (stream-append
+   (let loop ((i (compiled-code-block/constants-start o)))
+     (cond ((>= i (compiled-code-block/constants-end o)) (stream))
+	   (else 
+	    (stream* 
+	     (iline i (system-vector-ref o i))
+	     (loop (+ i compiled-code-block/bytes-per-object))))))
+   (stream (iline "debuginfo" (compiled-code-block/debugging-info o))
+	   (iline "env" (compiled-code-block/environment o))
+	   (with-output-to-string (lambda () (compiler:disassemble o))))))
+
+(define (inspect-scode o)
+  (stream (pprint-to-string o)))
+
+(define (probably-scode? o)
+  (define tests (list access? assignment? combination? comment?
+		      conditional? definition? delay? disjunction? lambda?
+		      quotation? sequence? the-environment? variable?))
+  (let loop ((tests tests))
+    (cond ((null? tests) #f)
+	  (((car tests) o))
+	  (else (loop (cdr tests))))))
+
+(define (inspect-system-pair o)
+  (stream (iline "car" (system-pair-car o))
+	  (iline "cdr" (system-pair-cdr o))))
+
+
+;;;; Auxilary functions
+
+(define nil '())
+(define t 't)
+(define (elisp-false? o) (member o '(nil ())))
+(define (elisp-true? o) (not (elisp-false? o)))
+(define (>line o) 
+  (let ((r (write-to-string o 100)))
+    (cond ((not (car r)) (cdr r))
+	  (else (string-append (cdr r) " ..")))))
+;; Must compile >line otherwise we can't write unassigend-reference-traps.
+(set! >line (compile-procedure >line))
+(define (read-from-string s) (with-input-from-string s read))
+(define (pprint-to-string o) 
+  (with-string-output-port 
+      (lambda (p)
+	(fluid-let ((*unparser-list-breadth-limit* 10)
+		    (*unparser-list-depth-limit* 4)
+		    (*unparser-string-length-limit* 100))
+	  (pp o p)))))
+;(define (1+ n) (+ n 1))
+(define (1- n) (- n 1))
+(define (package-lookup package name)
+  (let ((p (if (package? package) package (find-package package))))
+    (environment-lookup (package/environment p) name)))
+(define log-port (current-output-port))
+(define (log-event fstring . args)
+  ;;(apply format log-port fstring args)
+  #f
+  )
+
+;; Modified for Slimv:
+;; - restart swank server in a loop
+(let loop ()
+ (swank 4005)
+ (loop))
+
+;;; swank-mit-scheme.scm ends here

sources_non_forked/slimv/slime/contrib/swank-mrepl.lisp

@@ -0,0 +1,162 @@
+;;; swank-mrepl.lisp
+;;
+;; Licence: public domain
+
+(in-package :swank)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (let ((api '(
+	       *emacs-connection*
+	       channel 
+	       channel-id
+	       define-channel-method
+	       defslimefun 
+	       dcase
+	       log-event
+	       process-requests
+	       send-to-remote-channel
+	       use-threads-p
+	       wait-for-event
+	       with-bindings
+	       with-connection
+	       with-top-level-restart
+	       with-slime-interrupts
+	       )))
+    (eval `(defpackage #:swank-api
+	     (:use)
+	     (:import-from #:swank . ,api)
+	     (:export . ,api)))))
+
+(defpackage :swank-mrepl
+  (:use :cl :swank-api)
+  (:export #:create-mrepl))
+
+(in-package :swank-mrepl)
+
+(defclass listener-channel (channel)
+  ((remote :initarg :remote)
+   (env :initarg :env)
+   (mode :initform :eval)
+   (tag :initform nil)))
+
+(defun package-prompt (package)
+  (reduce (lambda (x y) (if (<= (length x) (length y)) x y))
+	  (cons (package-name package) (package-nicknames package))))
+
+(defslimefun create-mrepl (remote)
+  (let* ((pkg *package*)
+         (conn *emacs-connection*)
+	 (thread (if (use-threads-p)
+		     (spawn-listener-thread conn)
+		     nil))
+         (ch (make-instance 'listener-channel :remote remote :thread thread)))
+    (setf (slot-value ch 'env) (initial-listener-env ch))
+    (when thread
+      (swank/backend:send thread `(:serve-channel ,ch)))
+    (list (channel-id ch)
+	  (swank/backend:thread-id (or thread (swank/backend:current-thread)))
+	  (package-name pkg)
+	  (package-prompt pkg))))
+
+(defun initial-listener-env (listener)
+  `((*package* . ,*package*)
+    (*standard-output* . ,(make-listener-output-stream listener))
+    (*standard-input* . ,(make-listener-input-stream listener))))
+
+(defun spawn-listener-thread (connection)
+  (swank/backend:spawn 
+   (lambda ()
+     (with-connection (connection)
+       (dcase (swank/backend:receive)
+	 ((:serve-channel c)
+	  (loop
+	   (with-top-level-restart (connection (drop-unprocessed-events c))
+	     (process-requests nil)))))))
+   :name "mrepl thread"))
+
+(defun drop-unprocessed-events (channel)
+  (with-slots (mode) channel
+    (let ((old-mode mode))
+      (setf mode :drop)
+      (unwind-protect
+	   (process-requests t)
+	(setf mode old-mode)))
+    (send-prompt channel)))
+
+(define-channel-method :process ((c listener-channel) string)
+  (log-event ":process ~s~%" string)
+  (with-slots (mode remote) c
+    (ecase mode
+      (:eval (mrepl-eval c string))
+      (:read (mrepl-read c string))
+      (:drop))))
+
+(defun mrepl-eval (channel string)
+  (with-slots (remote env) channel
+    (let ((aborted t))
+      (with-bindings env
+	(unwind-protect 
+	     (let ((result (with-slime-interrupts (read-eval-print string))))
+	       (send-to-remote-channel remote `(:write-result ,result))
+	       (setq aborted nil))
+	  (setf env (loop for (sym) in env
+			  collect (cons sym (symbol-value sym))))
+	  (cond (aborted
+		 (send-to-remote-channel remote `(:evaluation-aborted)))
+		(t
+		 (send-prompt channel))))))))
+
+(defun send-prompt (channel)
+  (with-slots (env remote) channel
+    (let ((pkg (or (cdr (assoc '*package* env)) *package*))
+	  (out (cdr (assoc '*standard-output* env)))
+	  (in (cdr (assoc '*standard-input* env))))
+      (when out (force-output out))
+      (when in (clear-input in))
+      (send-to-remote-channel remote `(:prompt ,(package-name pkg)
+					       ,(package-prompt pkg))))))
+  
+(defun mrepl-read (channel string)
+  (with-slots (tag) channel
+    (assert tag)
+    (throw tag string)))
+
+(defun read-eval-print (string)
+  (with-input-from-string (in string)
+    (setq / ())
+    (loop
+       (let* ((form (read in nil in)))
+	 (cond ((eq form in) (return))
+	       (t (setq / (multiple-value-list (eval (setq + form))))))))
+    (force-output)
+    (if /
+	(format nil "~{~s~%~}" /) 
+	"; No values")))
+
+(defun make-listener-output-stream (channel)
+  (let ((remote (slot-value channel 'remote)))
+    (swank/backend:make-output-stream 
+     (lambda (string)
+       (send-to-remote-channel remote `(:write-string ,string))))))
+
+(defun make-listener-input-stream (channel)
+  (swank/backend:make-input-stream (lambda () (read-input channel))))
+
+(defun set-mode (channel new-mode)
+  (with-slots (mode remote) channel
+    (unless (eq mode new-mode)
+      (send-to-remote-channel remote `(:set-read-mode ,new-mode)))
+    (setf mode new-mode)))
+
+(defun read-input (channel)
+  (with-slots (mode tag remote) channel
+    (force-output)
+    (let ((old-mode mode)
+	  (old-tag tag))
+      (setf tag (cons nil nil))
+      (set-mode channel :read)
+      (unwind-protect 
+	   (catch tag (process-requests nil))
+	(setf tag old-tag)
+	(set-mode channel old-mode)))))
+
+(provide :swank-mrepl)

sources_non_forked/slimv/slime/contrib/swank-package-fu.lisp

@@ -0,0 +1,65 @@
+
+(in-package :swank)
+
+(defslimefun package= (string1 string2)
+  (let* ((pkg1 (guess-package string1))
+	 (pkg2 (guess-package string2)))
+    (and pkg1 pkg2 (eq pkg1 pkg2))))
+
+(defslimefun export-symbol-for-emacs (symbol-str package-str)
+  (let ((package (guess-package package-str)))
+    (when package
+      (let ((*buffer-package* package))
+	(export `(,(from-string symbol-str)) package)))))
+
+(defslimefun unexport-symbol-for-emacs (symbol-str package-str)
+  (let ((package (guess-package package-str)))
+    (when package
+      (let ((*buffer-package* package))
+	(unexport `(,(from-string symbol-str)) package)))))
+
+#+sbcl
+(defun list-structure-symbols (name)
+  (let ((dd (sb-kernel:find-defstruct-description name )))
+    (list* name
+           (sb-kernel:dd-default-constructor dd)
+           (sb-kernel:dd-predicate-name dd)
+           (sb-kernel::dd-copier-name dd)
+           (mapcar #'sb-kernel:dsd-accessor-name
+                   (sb-kernel:dd-slots dd)))))
+
+#+ccl
+(defun list-structure-symbols (name)
+  (let ((definition (gethash name ccl::%defstructs%)))
+    (list* name
+           (ccl::sd-constructor definition)
+           (ccl::sd-refnames definition))))
+
+(defun list-class-symbols (name)
+  (let* ((class (find-class name))
+         (slots (swank-mop:class-direct-slots class)))
+    (labels ((extract-symbol (name)
+               (if (and (consp name) (eql (car name) 'setf))
+                   (cadr name)
+                   name))
+             (slot-accessors (slot)
+               (nintersection (copy-list (swank-mop:slot-definition-readers slot))
+                              (copy-list (swank-mop:slot-definition-readers slot))
+                              :key #'extract-symbol)))
+      (list* (class-name class)
+             (mapcan #'slot-accessors slots)))))
+
+(defslimefun export-structure (name package)
+  (let ((*package* (guess-package package)))
+    (when *package*
+      (let* ((name (from-string name))
+             (symbols (cond #+(or sbcl ccl)
+			    ((or (not (find-class name nil))
+                                 (subtypep name 'structure-object))
+                             (list-structure-symbols name))
+                            (t
+                             (list-class-symbols name)))))
+        (export symbols)
+        symbols))))
+
+(provide :swank-package-fu)

sources_non_forked/slimv/slime/contrib/swank-presentation-streams.lisp

@@ -0,0 +1,334 @@
+;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities
+;;;                                     to portions of output
+;;;
+;;; Authors: Alan Ruttenberg  <alanr-l@mumble.net>
+;;;          Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>
+;;;          Helmut Eller  <heller@common-lisp.net>
+;;;
+;;; License: This code has been placed in the Public Domain.  All warranties
+;;;          are disclaimed.
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (swank-require :swank-presentations))
+
+;; This file contains a mechanism for printing to the slime repl so
+;; that the printed result remembers what object it is associated
+;; with.  This extends the recording of REPL results.
+;;
+;; There are two methods:
+;;
+;; 1. Depends on the ilisp bridge code being installed and ready to
+;;    intercept messages in the printed stream. We encode the
+;;    information with a message saying that we are starting to print
+;;    an object corresponding to a given id and another when we are
+;;    done. The process filter notices these and adds the necessary
+;;    text properties to the output.
+;;
+;; 2. Use separate protocol messages :presentation-start and
+;;    :presentation-end for sending presentations.
+;;
+;; We only do this if we know we are printing to a slime stream,
+;; checked with the method slime-stream-p. Initially this checks for
+;; the knows slime streams looking at *connections*. In cmucl, sbcl, and
+;; openmcl it also checks if it is a pretty-printing stream which
+;; ultimately prints to a slime stream.
+;;
+;; Method 1 seems to be faster, but the printed escape sequences can 
+;; disturb the column counting, and thus the layout in pretty-printing.
+;; We use method 1 when a dedicated output stream is used.  
+;;
+;; Method 2 is cleaner and works with pretty printing if the pretty
+;; printers support "annotations".  We use method 2 when no dedicated
+;; output stream is used.
+
+;; Control
+(defvar *enable-presenting-readable-objects* t
+  "set this to enable automatically printing presentations for some
+subset of readable objects, such as pathnames."  )
+
+;; doing it
+
+(defmacro presenting-object (object stream &body body)
+  "What you use in your code. Wrap this around some printing and that text will
+be sensitive and remember what object it is in the repl"
+  `(presenting-object-1 ,object ,stream #'(lambda () ,@body)))
+
+(defmacro presenting-object-if (predicate object stream &body body)
+  "What you use in your code. Wrap this around some printing and that text will
+be sensitive and remember what object it is in the repl if predicate is true"
+  (let ((continue (gensym)))
+  `(let ((,continue #'(lambda () ,@body)))
+    (if ,predicate
+	(presenting-object-1 ,object ,stream ,continue)
+	(funcall ,continue)))))
+
+;;; Get pretty printer patches for SBCL at load (not compile) time.
+#+#:disable-dangerous-patching ; #+sbcl
+(eval-when (:load-toplevel)
+  (handler-bind ((simple-error
+		  (lambda (c)
+		    (declare (ignore c))
+		    (let ((clobber-it (find-restart 'sb-kernel::clobber-it)))
+		      (when clobber-it (invoke-restart clobber-it))))))
+    (sb-ext:without-package-locks
+      (swank/sbcl::with-debootstrapping
+	(load (make-pathname
+	       :name "sbcl-pprint-patch"
+	       :type "lisp"
+	       :directory (pathname-directory
+			   swank-loader:*source-directory*)))))))
+
+(let ((last-stream nil)
+      (last-answer nil))
+  (defun slime-stream-p (stream)
+    "Check if stream is one of the slime streams, since if it isn't we
+don't want to present anything.
+Two special return values: 
+:DEDICATED -- Output ends up on a dedicated output stream
+:REPL-RESULT -- Output ends up on the :repl-results target.
+"
+    (if (eq last-stream stream)
+	last-answer
+	(progn
+	  (setq last-stream stream)
+	  (if (eq stream t) 
+	      (setq stream *standard-output*))
+	  (setq last-answer 
+		(or #+openmcl 
+		    (and (typep stream 'ccl::xp-stream) 
+					;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure)))
+			 (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1)))
+		    #+cmu
+		    (or (and (typep stream 'lisp::indenting-stream)
+			     (slime-stream-p (lisp::indenting-stream-stream stream)))
+			(and (typep stream 'pretty-print::pretty-stream)
+			     (fboundp 'pretty-print::enqueue-annotation)
+			     (let ((slime-stream-p
+				    (slime-stream-p (pretty-print::pretty-stream-target stream))))
+			       (and ;; Printing through CMUCL pretty
+				    ;; streams is only cleanly
+				    ;; possible if we are using the
+				    ;; bridge-less protocol with
+				    ;; annotations, because the bridge
+				    ;; escape sequences disturb the
+				    ;; pretty printer layout.
+				    (not (eql slime-stream-p :dedicated-output))
+				    ;; If OK, return the return value
+				    ;; we got from slime-stream-p on
+				    ;; the target stream (could be
+				    ;; :repl-result):
+				    slime-stream-p))))
+		    #+sbcl
+		    (let ()
+		      (declare (notinline sb-pretty::pretty-stream-target))
+		      (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))
+                           (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)
+                           (not *use-dedicated-output-stream*)
+                           (slime-stream-p (sb-pretty::pretty-stream-target stream))))
+		    #+allegro
+		    (and (typep stream 'excl:xp-simple-stream)
+			 (slime-stream-p (excl::stream-output-handle stream)))
+		    (loop for connection in *connections*
+			  thereis (or (and (eq stream (connection.dedicated-output connection))
+					   :dedicated)
+				      (eq stream (connection.socket-io connection))
+				      (eq stream (connection.user-output connection))
+				      (eq stream (connection.user-io connection))
+				      (and (eq stream (connection.repl-results connection))
+					   :repl-result)))))))))
+
+(defun can-present-readable-objects (&optional stream)
+  (declare (ignore stream))
+  *enable-presenting-readable-objects*)
+
+;; If we are printing to an XP (pretty printing) stream, printing the
+;; escape sequences directly would mess up the layout because column
+;; counting is disturbed.  Use "annotations" instead.
+#+allegro
+(defun write-annotation (stream function arg)
+  (if (typep stream 'excl:xp-simple-stream)
+      (excl::schedule-annotation stream function arg)
+      (funcall function arg stream nil)))
+#+cmu
+(defun write-annotation (stream function arg)
+  (if (and (typep stream 'pp:pretty-stream)
+	   (fboundp 'pp::enqueue-annotation))
+      (pp::enqueue-annotation stream function arg)
+      (funcall function arg stream nil)))
+#+sbcl
+(defun write-annotation (stream function arg)
+  (let ((enqueue-annotation
+	 (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)))
+    (if (and enqueue-annotation
+	     (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)))
+	(funcall enqueue-annotation stream function arg)
+	(funcall function arg stream nil))))
+#-(or allegro cmu sbcl)
+(defun write-annotation (stream function arg)
+  (funcall function arg stream nil))
+
+(defstruct presentation-record 
+  (id)
+  (printed-p)
+  (target))
+
+(defun presentation-start (record stream truncatep) 
+  (unless truncatep
+    ;; Don't start new presentations when nothing is going to be
+    ;; printed due to *print-lines*.
+    (let ((pid (presentation-record-id record))
+	  (target (presentation-record-target record)))
+      (case target
+	(:dedicated 
+	 ;; Use bridge protocol
+	 (write-string "<" stream)
+	 (prin1 pid stream)
+	 (write-string "" stream))
+	(t
+	 (finish-output stream)
+	 (send-to-emacs `(:presentation-start ,pid ,target)))))
+    (setf (presentation-record-printed-p record) t)))
+	   
+(defun presentation-end (record stream truncatep)
+  (declare (ignore truncatep))
+  ;; Always end old presentations that were started.
+  (when (presentation-record-printed-p record)
+    (let ((pid (presentation-record-id record))
+	  (target (presentation-record-target record)))
+      (case target
+	(:dedicated 
+	 ;; Use bridge protocol
+	 (write-string ">" stream)
+	 (prin1 pid stream)
+	 (write-string "" stream))
+	(t
+	 (finish-output stream)
+	 (send-to-emacs `(:presentation-end ,pid ,target)))))))
+
+(defun presenting-object-1 (object stream continue)
+  "Uses the bridge mechanism with two messages >id and <id. The first one
+says that I am starting to print an object with this id. The second says I am finished"
+  ;; this declare special is to let the compiler know that *record-repl-results* will eventually be
+  ;; a global special, even if it isn't when this file is compiled/loaded.
+  (declare (special *record-repl-results*))
+  (let ((slime-stream-p 
+	 (and *record-repl-results* (slime-stream-p stream))))
+    (if slime-stream-p
+	(let* ((pid (swank::save-presented-object object))
+	       (record (make-presentation-record :id pid :printed-p nil
+						 :target (if (eq slime-stream-p :repl-result)
+							     :repl-result
+							     nil))))
+	  (write-annotation stream #'presentation-start record)
+	  (multiple-value-prog1
+	      (funcall continue)
+	    (write-annotation stream #'presentation-end record)))
+	(funcall continue))))
+
+(defun present-repl-results-via-presentation-streams (values)
+  ;; Override a function in swank.lisp, so that 
+  ;; nested presentations work in the REPL result.
+  (let ((repl-results (connection.repl-results *emacs-connection*)))
+    (flet ((send (value)
+	     (presenting-object value repl-results
+	       (prin1 value repl-results))
+	     (terpri repl-results)))
+      (if (null values)
+	  (progn 
+	    (princ "; No value" repl-results)
+	    (terpri repl-results))
+	  (mapc #'send values)))
+    (finish-output repl-results)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#+openmcl
+(in-package :ccl)
+
+#+openmcl
+(defun monkey-patch-stream-printing ()
+  (let ((*warn-if-redefine-kernel* nil)
+	(*warn-if-redefine* nil))
+    (defun %print-unreadable-object (object stream type id thunk)
+      (cond ((null stream) (setq stream *standard-output*))
+	    ((eq stream t) (setq stream *terminal-io*)))
+      (swank::presenting-object object stream
+	(write-unreadable-start object stream)
+	(when type
+	  (princ (type-of object) stream)
+	  (stream-write-char stream #\space))
+	(when thunk
+	  (funcall thunk))
+	(if id
+	    (%write-address object stream #\>)
+	    (pp-end-block stream ">"))
+	nil))
+    (defmethod print-object :around ((pathname pathname) stream)
+      (swank::presenting-object-if
+	  (swank::can-present-readable-objects stream)
+	  pathname stream (call-next-method))))
+  (ccl::def-load-pointers clear-presentations ()
+    (swank::clear-presentation-tables)))
+
+(in-package :swank)
+
+#+cmu
+(progn
+  (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body)
+    (presenting-object object stream
+      (fwrappers:call-next-function)))
+
+  (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth)
+    (presenting-object-if (can-present-readable-objects stream) pathname stream
+      (fwrappers:call-next-function)))
+
+  (defun monkey-patch-stream-printing ()
+    (fwrappers::fwrap 'lisp::%print-pathname  #'presenting-pathname-wrapper)
+    (fwrappers::fwrap 'lisp::%print-unreadable-object  #'presenting-unreadable-wrapper)))
+
+#+sbcl
+(progn
+  (defvar *saved-%print-unreadable-object*
+    (fdefinition 'sb-impl::%print-unreadable-object))
+
+  (defun monkey-patch-stream-printing ()
+    (sb-ext:without-package-locks
+      (when (eq (fdefinition 'sb-impl::%print-unreadable-object)
+		*saved-%print-unreadable-object*)
+	(setf (fdefinition 'sb-impl::%print-unreadable-object)
+	      (lambda (object stream &rest args)
+		(presenting-object object stream
+                  (apply *saved-%print-unreadable-object*
+                         object stream args)))))
+      (defmethod print-object :around ((object pathname) stream)
+	(presenting-object object stream
+	  (call-next-method))))))
+
+#+allegro
+(progn
+  (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation)
+    (swank::presenting-object object stream (excl:call-next-fwrapper)))
+  (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth)
+    (presenting-object-if (can-present-readable-objects stream) pathname stream
+      (excl:call-next-fwrapper)))
+  (defun monkey-patch-stream-printing ()
+    (excl:fwrap 'excl::print-unreadable-object-1
+		'print-unreadable-present 'presenting-unreadable-wrapper)
+    (excl:fwrap 'excl::pathname-printer
+		'print-pathname-present 'presenting-pathname-wrapper)))
+
+#-(or allegro sbcl cmu openmcl)
+(defun monkey-patch-stream-printing ()
+  (values))
+
+;; Hook into SWANK.
+
+(defslimefun init-presentation-streams ()
+  (monkey-patch-stream-printing)
+  ;; FIXME: import/use swank-repl to avoid package qualifier.
+  (setq swank-repl:*send-repl-results-function*
+	'present-repl-results-via-presentation-streams))
+
+(provide :swank-presentation-streams)

sources_non_forked/slimv/slime/contrib/swank-presentations.lisp

@@ -0,0 +1,246 @@
+;;; swank-presentations.lisp --- imitate LispM's presentations
+;;
+;; Authors: Alan Ruttenberg  <alanr-l@mumble.net>
+;;          Luke Gorrie  <luke@synap.se>
+;;          Helmut Eller  <heller@common-lisp.net>
+;;          Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>
+;;
+;; License: This code has been placed in the Public Domain.  All warranties
+;;          are disclaimed.
+;;
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (swank-require :swank-repl))
+
+;;;; Recording and accessing results of computations
+
+(defvar *record-repl-results* t
+  "Non-nil means that REPL results are saved for later lookup.")
+
+(defvar *object-to-presentation-id*
+  (make-weak-key-hash-table :test 'eq)
+  "Store the mapping of objects to numeric identifiers")
+
+(defvar *presentation-id-to-object*
+  (make-weak-value-hash-table :test 'eql)
+  "Store the mapping of numeric identifiers to objects")
+
+(defun clear-presentation-tables ()
+  (clrhash *object-to-presentation-id*)
+  (clrhash *presentation-id-to-object*))
+
+(defvar *presentation-counter* 0 "identifier counter")
+
+(defvar *nil-surrogate* (make-symbol "nil-surrogate"))
+
+;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the
+;; rest of slime isn't thread safe either), do we really care?
+(defun save-presented-object (object)
+  "Save OBJECT and return the assigned id.
+If OBJECT was saved previously return the old id."
+  (let ((object (if (null object) *nil-surrogate* object)))
+    ;; We store *nil-surrogate* instead of nil, to distinguish it from
+    ;; an object that was garbage collected.
+    (or (gethash object *object-to-presentation-id*)
+        (let ((id (incf *presentation-counter*)))
+          (setf (gethash id *presentation-id-to-object*) object)
+          (setf (gethash object *object-to-presentation-id*) id)
+          id))))
+
+(defslimefun lookup-presented-object (id)
+  "Retrieve the object corresponding to ID.
+The secondary value indicates the absence of an entry."
+  (etypecase id
+    (integer
+     ;;
+     (multiple-value-bind (object foundp)
+         (gethash id *presentation-id-to-object*)
+       (cond
+         ((eql object *nil-surrogate*)
+          ;; A stored nil object
+          (values nil t))
+         ((null object)
+          ;; Object that was replaced by nil in the weak hash table
+          ;; when the object was garbage collected.
+          (values nil nil))
+         (t
+          (values object foundp)))))
+    (cons
+     (dcase id
+       ((:frame-var thread-id frame index)
+        (declare (ignore thread-id)) ; later
+        (handler-case
+            (frame-var-value frame index)
+          (t (condition)
+            (declare (ignore condition))
+            (values nil nil))
+          (:no-error (value)
+            (values value t))))
+       ((:inspected-part part-index)
+        (inspector-nth-part part-index))))))
+
+(defslimefun lookup-presented-object-or-lose (id)
+  "Get the result of the previous REPL evaluation with ID."
+  (multiple-value-bind (object foundp) (lookup-presented-object id)
+    (cond (foundp object)
+          (t (error "Attempt to access unrecorded object (id ~D)." id)))))
+
+(defslimefun lookup-and-save-presented-object-or-lose (id)
+  "Get the object associated with ID and save it in the presentation tables."
+  (let ((obj (lookup-presented-object-or-lose id)))
+    (save-presented-object obj)))
+
+(defslimefun clear-repl-results ()
+  "Forget the results of all previous REPL evaluations."
+  (clear-presentation-tables)
+  t)
+
+(defun present-repl-results (values)
+  ;; Override a function in swank.lisp, so that
+  ;; presentations are associated with every REPL result.
+  (flet ((send (value)
+           (let ((id (and *record-repl-results*
+                          (save-presented-object value))))
+	     (send-to-emacs `(:presentation-start ,id :repl-result))
+	     (send-to-emacs `(:write-string ,(prin1-to-string value)
+					    :repl-result))
+	     (send-to-emacs `(:presentation-end ,id :repl-result))
+	     (send-to-emacs `(:write-string ,(string #\Newline)
+					    :repl-result)))))
+    (fresh-line)
+    (finish-output)
+    (if (null values)
+        (send-to-emacs `(:write-string "; No value" :repl-result))
+        (mapc #'send values))))
+
+
+;;;; Presentation menu protocol
+;;
+;; To define a menu for a type of object, define a method
+;; menu-choices-for-presentation on that object type.  This function
+;; should return a list of two element lists where the first element is
+;; the name of the menu action and the second is a function that will be
+;; called if the menu is chosen. The function will be called with 3
+;; arguments:
+;;
+;; choice: The string naming the action from above
+;;
+;; object: The object
+;;
+;; id: The presentation id of the object
+;;
+;; You might want append (when (next-method-p) (call-next-method)) to
+;; pick up the Menu actions of superclasses.
+;;
+
+(defvar *presentation-active-menu* nil)
+
+(defun menu-choices-for-presentation-id (id)
+  (multiple-value-bind (ob presentp) (lookup-presented-object id)
+    (cond ((not presentp) 'not-present)
+	  (t
+	   (let ((menu-and-actions (menu-choices-for-presentation ob)))
+	     (setq *presentation-active-menu* (cons id menu-and-actions))
+	     (mapcar 'car menu-and-actions))))))
+
+(defun swank-ioify (thing)
+  (cond ((keywordp thing) thing)
+	((and (symbolp thing)(not (find #\: (symbol-name thing))))
+	 (intern (symbol-name thing) 'swank-io-package))
+	((consp thing) (cons (swank-ioify (car thing))
+			     (swank-ioify (cdr thing))))
+	(t thing)))
+
+(defun execute-menu-choice-for-presentation-id (id count item)
+  (let ((ob (lookup-presented-object id)))
+    (assert (equal id (car *presentation-active-menu*)) ()
+	    "Bug: Execute menu call for id ~a  but menu has id ~a"
+	    id (car *presentation-active-menu*))
+    (let ((action (second (nth (1- count) (cdr *presentation-active-menu*)))))
+      (swank-ioify (funcall action item ob id)))))
+
+
+(defgeneric menu-choices-for-presentation (object)
+  (:method (ob) (declare (ignore ob)) nil)) ; default method
+
+;; Pathname
+(defmethod menu-choices-for-presentation ((ob pathname))
+  (let* ((file-exists (ignore-errors (probe-file ob)))
+	 (lisp-type (make-pathname :type "lisp"))
+	 (source-file (and (not (member (pathname-type ob) '("lisp" "cl")
+					:test 'equal))
+			   (let ((source (merge-pathnames lisp-type ob)))
+			     (and (ignore-errors (probe-file source))
+				  source))))
+	 (fasl-file (and file-exists
+			 (equal (ignore-errors
+				  (namestring
+				   (truename
+				    (compile-file-pathname
+				     (merge-pathnames lisp-type ob)))))
+				(namestring (truename ob))))))
+    (remove nil
+	    (list*
+	     (and (and file-exists (not fasl-file))
+		  (list "Edit this file"
+			(lambda(choice object id)
+			  (declare (ignore choice id))
+			  (ed-in-emacs (namestring (truename object)))
+			  nil)))
+	     (and file-exists
+		  (list "Dired containing directory"
+			(lambda (choice object id)
+			  (declare (ignore choice id))
+			  (ed-in-emacs (namestring
+					(truename
+					 (merge-pathnames
+					  (make-pathname :name "" :type "")
+					  object))))
+			  nil)))
+	     (and fasl-file
+		  (list "Load this fasl file"
+			(lambda (choice object id)
+			  (declare (ignore choice id object))
+			  (load ob)
+			  nil)))
+	     (and fasl-file
+		  (list "Delete this fasl file"
+			(lambda (choice object id)
+			  (declare (ignore choice id object))
+			  (let ((nt (namestring (truename ob))))
+			    (when (y-or-n-p-in-emacs "Delete ~a? " nt)
+			      (delete-file nt)))
+			  nil)))
+	     (and source-file
+		  (list "Edit lisp source file"
+			(lambda (choice object id)
+			  (declare (ignore choice id object))
+			  (ed-in-emacs (namestring (truename source-file)))
+			  nil)))
+	     (and source-file
+		  (list "Load lisp source file"
+			(lambda(choice object id)
+			  (declare (ignore choice id object))
+			  (load source-file)
+			  nil)))
+	     (and (next-method-p) (call-next-method))))))
+
+(defmethod menu-choices-for-presentation ((ob function))
+  (list (list "Disassemble"
+              (lambda (choice object id)
+                (declare (ignore choice id))
+                (disassemble object)))))
+
+(defslimefun inspect-presentation (id reset-p)
+  (let ((what (lookup-presented-object-or-lose id)))
+    (when reset-p
+      (reset-inspector))
+    (inspect-object what)))
+
+(defslimefun init-presentations ()
+  ;; FIXME: import/use swank-repl to avoid package qualifier.
+  (setq swank-repl:*send-repl-results-function* 'present-repl-results))
+
+(provide :swank-presentations)

sources_non_forked/slimv/slime/contrib/swank-quicklisp.lisp

@@ -0,0 +1,17 @@
+;;; swank-quicklisp.lisp -- Quicklisp support
+;;
+;; Authors: Matthew Kennedy <burnsidemk@gmail.com>
+;; License: Public Domain
+;;
+
+(in-package :swank)
+
+(defslimefun list-quicklisp-systems ()
+  "Returns the Quicklisp systems list."
+  (if (member :quicklisp *features*)
+      (let ((ql-dist-name (find-symbol "NAME" "QL-DIST"))
+            (ql-system-list (find-symbol "SYSTEM-LIST" "QL")))
+        (mapcar ql-dist-name (funcall ql-system-list)))
+      (error "Could not find Quicklisp already loaded.")))
+
+(provide :swank-quicklisp)

sources_non_forked/slimv/slime/contrib/swank-r6rs.scm

@@ -0,0 +1,416 @@
+;; swank-r6rs.sls --- Shareable code between swank-ikarus and swank-larceny
+;;
+;; Licence: public domain
+;; Author: Helmut Eller
+;;
+;; This is a Swank server barely capable enough to process simple eval
+;; requests from Emacs before dying.  No fancy features like
+;; backtraces, module redefintion, M-. etc. are implemented.  Don't
+;; even think about pc-to-source mapping.
+;;
+;; Despite standard modules, this file uses (swank os) and (swank sys)
+;; which define implementation dependend functionality.  There are
+;; multiple modules in this files, which is probably not standardized.
+;;
+
+;; Naive FORMAT implementation which supports: ~a ~s ~d ~x ~c
+(library (swank format)
+    (export format printf fprintf)
+    (import (rnrs))
+
+ (define (format f . args)
+   (call-with-string-output-port
+    (lambda (port) (apply fprintf port f args))))
+
+ (define (printf f . args)
+   (let ((port (current-output-port)))
+     (apply fprintf port f args)
+     (flush-output-port port)))
+
+ (define (fprintf port f . args)
+   (let ((len (string-length f)))
+     (let loop ((i 0) (args args))
+       (cond ((= i len) (assert (null? args)))
+	     ((and (char=? (string-ref f i) #\~)
+		   (< (+ i 1) len))
+	      (dispatch-format (string-ref f (+ i 1)) port (car args))
+	      (loop (+ i 2) (cdr args)))
+	     (else
+	      (put-char port (string-ref f i))
+	      (loop (+ i 1) args))))))
+ 
+ (define (dispatch-format char port arg)
+   (let ((probe (assoc char format-dispatch-table)))
+     (cond (probe ((cdr probe) arg port))
+	   (else (error "invalid format char: " char)))))
+
+ (define format-dispatch-table 
+   `((#\a . ,display)
+     (#\s . ,write)
+     (#\d . ,(lambda (arg port) (put-string port (number->string arg 10))))
+     (#\x . ,(lambda (arg port) (put-string port (number->string arg 16))))
+     (#\c . ,(lambda (arg port) (put-char port arg))))))
+
+
+;; CL-style restarts to let us continue after errors.
+(library (swank restarts)
+    (export with-simple-restart compute-restarts invoke-restart restart-name
+	    write-restart-report)
+    (import (rnrs))
+
+ (define *restarts* '())
+
+ (define-record-type restart
+   (fields name reporter continuation))
+ 
+ (define (with-simple-restart name reporter thunk)
+   (call/cc 
+    (lambda (k)
+      (let ((old-restarts *restarts*)
+	    (restart (make-restart name (coerce-to-reporter reporter) k)))
+	(dynamic-wind
+	    (lambda () (set! *restarts* (cons restart old-restarts)))
+	    thunk
+	    (lambda () (set! *restarts* old-restarts)))))))
+
+ (define (compute-restarts) *restarts*)
+
+ (define (invoke-restart restart . args)
+   (apply (restart-continuation restart) args))
+
+ (define (write-restart-report restart port)
+   ((restart-reporter restart) port))
+
+ (define (coerce-to-reporter obj)
+   (cond ((string? obj) (lambda (port) (put-string port obj)))
+	 (#t (assert (procedure? obj)) obj)))
+
+ )
+
+;; This module encodes & decodes messages from the wire and queues them.
+(library (swank event-queue)
+    (export make-event-queue wait-for-event enqueue-event 
+	    read-event write-event)
+    (import (rnrs)
+	    (rnrs mutable-pairs)
+	    (swank format))
+
+ (define-record-type event-queue
+   (fields (mutable q) wait-fun)
+   (protocol (lambda (init)
+	       (lambda (wait-fun)
+		 (init '() wait-fun)))))
+
+ (define (wait-for-event q pattern)
+   (or (poll q pattern)
+       (begin
+	 ((event-queue-wait-fun q) q)
+	 (wait-for-event q pattern))))
+ 
+ (define (poll q pattern)
+   (let loop ((lag #f)
+	      (l (event-queue-q q)))
+     (cond ((null? l) #f)
+	   ((event-match? (car l) pattern)
+	    (cond (lag 
+		   (set-cdr! lag (cdr l))
+		   (car l))
+		  (else
+		   (event-queue-q-set! q (cdr l))
+		   (car l))))
+	   (else (loop l (cdr l))))))
+
+ (define (event-match? event pattern)
+   (cond ((or (number? pattern)
+	      (member pattern '(t nil)))
+	  (equal? event pattern))
+	 ((symbol? pattern) #t)
+	 ((pair? pattern)
+	  (case (car pattern)
+	    ((quote) (equal? event (cadr pattern)))
+	    ((or) (exists (lambda (p) (event-match? event p)) (cdr pattern)))
+	    (else (and (pair? event)
+		       (event-match? (car event) (car pattern))
+		       (event-match? (cdr event) (cdr pattern))))))
+	 (else (error "Invalid pattern: " pattern))))
+ 
+ (define (enqueue-event q event)
+   (event-queue-q-set! q
+		       (append (event-queue-q q) 
+			       (list event))))
+
+ (define (write-event event port)
+   (let ((payload (call-with-string-output-port
+		   (lambda (port) (write event port)))))
+     (write-length (string-length payload) port)
+     (put-string port payload)
+     (flush-output-port port)))
+
+ (define (write-length len port)
+   (do ((i 24 (- i 4)))
+       ((= i 0))
+     (put-string port
+		 (number->string (bitwise-bit-field len (- i 4) i)
+				 16))))
+
+ (define (read-event port)
+   (let* ((header (string-append (get-string-n port 2) 
+				 (get-string-n port 2)
+				 (get-string-n port 2)))
+	  (_ (printf "header: ~s\n" header))
+	  (len (string->number header 16))
+	  (_ (printf "len: ~s\n" len))
+	  (payload (get-string-n port len)))
+     (printf "payload: ~s\n" payload)
+     (read (open-string-input-port payload))))
+
+ )
+
+;; Entry points for SLIME commands.
+(library (swank rpc)
+    (export connection-info interactive-eval
+	    ;;compile-string-for-emacs 
+	    throw-to-toplevel sldb-abort
+	    operator-arglist buffer-first-change
+	    create-repl listener-eval)
+    (import (rnrs)
+	    (rnrs eval)
+	    (only (rnrs r5rs) scheme-report-environment)
+	    (swank os)
+	    (swank format)
+	    (swank restarts)
+	    (swank sys)
+	    )
+ 
+ (define (connection-info . _)
+   `(,@'()
+     :pid ,(getpid) 
+     :package (:name ">" :prompt ">")
+     :lisp-implementation (,@'() 
+			   :name ,(implementation-name)
+			   :type "R6RS-Scheme")))
+
+ (define (interactive-eval string)
+   (call-with-values 
+       (lambda ()
+	 (eval-in-interaction-environment (read-from-string string)))
+     (case-lambda
+      (() "; no value")
+      ((value) (format "~s" value))
+      (values (format "values: ~s" values)))))
+ 
+ (define (throw-to-toplevel) (invoke-restart-by-name-or-nil 'toplevel))
+
+ (define (sldb-abort) (invoke-restart-by-name-or-nil 'abort))
+ 
+ (define (invoke-restart-by-name-or-nil name)
+   (let ((r (find (lambda (r) (eq? (restart-name r) name))
+		  (compute-restarts))))
+     (if r (invoke-restart r) 'nil)))
+
+ (define (create-repl target)
+   (list "" ""))
+
+ (define (listener-eval string)
+   (call-with-values (lambda () (eval-region string))
+     (lambda values `(:values ,@(map (lambda (v) (format "~s" v)) values)))))
+
+ (define (eval-region string)
+   (let ((sexp (read-from-string string)))
+     (if (eof-object? exp)
+	 (values)
+	 (eval-in-interaction-environment sexp))))
+
+ (define (read-from-string string)
+   (call-with-port (open-string-input-port string) read))
+
+ (define (operator-arglist . _) 'nil)
+ (define (buffer-first-change . _) 'nil)
+
+ )
+
+;; The server proper.  Does the TCP stuff and exception handling.
+(library (swank)
+    (export start-server)
+    (import (rnrs) 
+	    (rnrs eval)
+	    (swank os)
+	    (swank format)
+	    (swank event-queue)
+	    (swank restarts))
+
+ (define-record-type connection
+   (fields in-port out-port event-queue))
+
+ (define (start-server port)
+   (accept-connections (or port 4005) #f))
+
+ (define (start-server/port-file port-file)
+   (accept-connections #f port-file))
+
+ (define (accept-connections port port-file)
+   (let ((sock (make-server-socket port)))
+     (printf "Listening on port: ~s\n" (local-port sock))
+     (when port-file 
+       (write-port-file (local-port sock) port-file))
+     (let-values (((in out) (accept sock (latin-1-codec))))
+       (dynamic-wind 
+	   (lambda () #f)
+	   (lambda () 
+	     (close-socket sock)
+	     (serve in out))
+	   (lambda () 
+	     (close-port in)
+	     (close-port out))))))
+
+ (define (write-port-file port port-file)
+   (call-with-output-file 
+       (lambda (file) 
+	 (write port file))))
+
+ (define (serve in out) 
+   (let ((err (current-error-port))
+	 (q (make-event-queue 
+	     (lambda (q)
+	       (let ((e (read-event in)))
+		 (printf "read: ~s\n" e)
+		 (enqueue-event q e))))))
+     (dispatch-loop (make-connection in out q))))
+
+ (define-record-type sldb-state
+   (fields level condition continuation next))
+
+ (define (dispatch-loop conn)
+   (let ((event (wait-for-event (connection-event-queue conn) 'x)))
+     (case (car event)
+       ((:emacs-rex) 
+	(with-simple-restart 
+	 'toplevel "Return to SLIME's toplevel"
+	 (lambda ()
+	   (apply emacs-rex conn #f (cdr event)))))
+       (else (error "Unhandled event: ~s" event))))
+   (dispatch-loop conn))
+
+ (define (recover thunk on-error-thunk)
+   (let ((ok #f))
+     (dynamic-wind 
+	 (lambda () #f) 
+	 (lambda () 
+	   (call-with-values thunk 
+	     (lambda vals 
+	       (set! ok #t) 
+	       (apply values vals))))
+	 (lambda ()
+	   (unless ok
+	     (on-error-thunk))))))
+
+ ;; Couldn't resist to exploit the prefix feature.
+ (define rpc-entries (environment '(prefix (swank rpc) swank:)))
+ 
+ (define (emacs-rex conn sldb-state form package thread tag)
+   (let ((out (connection-out-port conn)))
+     (recover
+      (lambda ()
+	(with-exception-handler
+	 (lambda (condition) 
+	   (call/cc 
+	    (lambda (k)
+	      (sldb-exception-handler conn condition k sldb-state))))
+	 (lambda ()
+	   (let ((value (apply (eval (car form) rpc-entries) (cdr form))))
+	     (write-event `(:return (:ok ,value) ,tag) out)))))
+      (lambda ()
+	(write-event `(:return (:abort) ,tag) out)))))
+
+ (define (sldb-exception-handler connection condition k sldb-state)
+   (when (serious-condition? condition)
+     (let ((level (if sldb-state (+ (sldb-state-level sldb-state) 1) 1))
+	   (out (connection-out-port connection)))
+       (write-event `(:debug 0 ,level ,@(debugger-info condition connection))
+		    out)
+       (dynamic-wind
+	   (lambda () #f)
+	   (lambda ()
+	     (sldb-loop connection 
+			(make-sldb-state level condition k sldb-state)))
+	   (lambda () (write-event `(:debug-return 0 ,level nil) out))))))
+
+ (define (sldb-loop connection state)
+   (apply emacs-rex connection state
+	  (cdr (wait-for-event (connection-event-queue connection) 
+			       '(':emacs-rex . _))))
+   (sldb-loop connection state))
+
+ (define (debugger-info condition connection)
+   (list `(,(call-with-string-output-port 
+	     (lambda (port) (print-condition condition port)))
+	   ,(format " [type ~s]" (if (record? condition)
+				     (record-type-name (record-rtd condition))
+				     ))
+	   ())
+	 (map (lambda (r) 
+		(list (format "~a" (restart-name r))
+		      (call-with-string-output-port
+		       (lambda (port)
+			 (write-restart-report r port)))))
+	      (compute-restarts))
+	 '()
+	 '()))
+
+ (define (print-condition obj port)
+   (cond ((condition? obj)
+	  (let ((list (simple-conditions obj)))
+	    (case (length list)
+	      ((0)
+	       (display "Compuond condition with zero components" port))
+	      ((1)
+	       (assert (eq? obj (car list)))
+	       (print-simple-condition (car list) port))
+	      (else
+	       (display "Compound condition:\n" port)
+	       (for-each (lambda (c)
+			   (display "  " port)
+			   (print-simple-condition c port)
+			   (newline port))
+			 list)))))
+	 (#t
+	  (fprintf port "Non-condition object: ~s" obj))))
+
+ (define (print-simple-condition condition port)
+   (fprintf port "~a" (record-type-name (record-rtd condition)))
+   (case (count-record-fields condition)
+     ((0) #f)
+     ((1) 
+      (fprintf port ": ")
+      (do-record-fields condition (lambda (name value) (write value port))))
+     (else
+      (fprintf port ":")
+      (do-record-fields condition (lambda (name value) 
+				    (fprintf port "\n~a: ~s" name value))))))
+
+ ;; Call FUN with RECORD's rtd and parent rtds.
+ (define (do-record-rtds record fun)
+   (do ((rtd (record-rtd record) (record-type-parent rtd)))
+       ((not rtd))
+     (fun rtd)))
+
+ ;; Call FUN with RECORD's field names and values.
+ (define (do-record-fields record fun)
+   (do-record-rtds 
+    record
+    (lambda (rtd)
+      (let* ((names (record-type-field-names rtd))
+	     (len (vector-length names)))
+	(do ((i 0 (+ 1 i)))
+	    ((= i len))
+	  (fun (vector-ref names i) ((record-accessor rtd i) record)))))))
+
+ ;; Return the number of fields in RECORD
+ (define (count-record-fields record)
+   (let ((i 0))
+     (do-record-rtds 
+      record (lambda (rtd) 
+	       (set! i (+ i (vector-length (record-type-field-names rtd))))))
+     i))
+
+ )

sources_non_forked/slimv/slime/contrib/swank-repl.lisp

@@ -0,0 +1,441 @@
+;;; swank-repl.lisp --- Server side part of the Lisp listener.
+;;
+;; License: public domain
+(in-package swank)
+
+(defpackage swank-repl
+  (:use cl swank/backend)
+  (:export *send-repl-results-function*)
+  (:import-from
+   swank
+
+   *default-worker-thread-bindings*
+
+   *loopback-interface*
+
+   add-hook
+   *connection-closed-hook*
+
+   eval-region
+   with-buffer-syntax
+
+   connection
+   connection.socket-io
+   connection.repl-results
+   connection.user-input
+   connection.user-output
+   connection.user-io
+   connection.trace-output
+   connection.dedicated-output
+   connection.env
+
+   multithreaded-connection
+   mconn.active-threads
+   mconn.repl-thread
+   mconn.auto-flush-thread
+   use-threads-p
+
+   *emacs-connection*
+   default-connection
+   with-connection
+
+   send-to-emacs
+   *communication-style*
+   handle-requests
+   wait-for-event
+   make-tag
+   thread-for-evaluation
+   socket-quest
+
+   authenticate-client
+   encode-message
+
+   auto-flush-loop
+   clear-user-input
+
+   current-thread-id
+   cat
+   with-struct*
+   with-retry-restart
+   with-bindings
+
+   package-string-for-prompt
+   find-external-format-or-lose
+
+   defslimefun
+
+   ;; FIXME: those should be exported from swank-repl only, but how to
+   ;; do that whithout breaking init files?
+   *use-dedicated-output-stream*
+   *dedicated-output-stream-port*
+   *globally-redirect-io*))
+
+(in-package swank-repl)
+
+(defvar *use-dedicated-output-stream* nil
+  "When T swank will attempt to create a second connection to Emacs
+which is used just to send output.")
+
+(defvar *dedicated-output-stream-port* 0
+  "Which port we should use for the dedicated output stream.")
+
+(defvar *dedicated-output-stream-buffering*
+  (if (eq *communication-style* :spawn) t nil)
+  "The buffering scheme that should be used for the output stream.
+Valid values are nil, t, :line")
+
+(defvar *globally-redirect-io* :started-from-emacs
+  "When T globally redirect all standard streams to Emacs.
+When :STARTED-FROM-EMACS redirect when launched by M-x slime")
+
+(defun globally-redirect-io-p ()
+  (case *globally-redirect-io*
+    ((t) t)
+    (:started-from-emacs swank-loader:*started-from-emacs*)))
+
+(defun open-streams (connection properties)
+  "Return the 5 streams for IO redirection:
+DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
+  (let* ((input-fn
+           (lambda ()
+             (with-connection (connection)
+               (with-simple-restart (abort-read
+                                     "Abort reading input from Emacs.")
+                 (read-user-input-from-emacs)))))
+         (dedicated-output (if *use-dedicated-output-stream*
+                               (open-dedicated-output-stream
+                                connection
+                                (getf properties :coding-system))))
+         (in (make-input-stream input-fn))
+         (out (or dedicated-output
+                  (make-output-stream (make-output-function connection))))
+         (io (make-two-way-stream in out))
+         (repl-results (swank:make-output-stream-for-target connection
+                                                            :repl-result)))
+    (typecase connection
+      (multithreaded-connection
+       (setf (mconn.auto-flush-thread connection)
+             (make-auto-flush-thread out))))
+    (values dedicated-output in out io repl-results)))
+
+(defun make-output-function (connection)
+  "Create function to send user output to Emacs."
+  (lambda (string)
+    (with-connection (connection)
+      (send-to-emacs `(:write-string ,string)))))
+
+(defun open-dedicated-output-stream (connection coding-system)
+  "Open a dedicated output connection to the Emacs on SOCKET-IO.
+Return an output stream suitable for writing program output.
+
+This is an optimized way for Lisp to deliver output to Emacs."
+  (let ((socket (socket-quest *dedicated-output-stream-port* nil))
+        (ef (find-external-format-or-lose coding-system)))
+    (unwind-protect
+         (let ((port (local-port socket)))
+           (encode-message `(:open-dedicated-output-stream ,port
+                                                           ,coding-system)
+                           (connection.socket-io connection))
+           (let ((dedicated (accept-connection
+                             socket
+                             :external-format ef
+                             :buffering *dedicated-output-stream-buffering*
+                             :timeout 30)))
+             (authenticate-client dedicated)
+             (close-socket socket)
+             (setf socket nil)
+             dedicated))
+      (when socket
+        (close-socket socket)))))
+
+(defmethod thread-for-evaluation ((connection multithreaded-connection)
+				  (id (eql :find-existing)))
+  (or (car (mconn.active-threads connection))
+      (find-repl-thread connection)))
+
+(defmethod thread-for-evaluation ((connection multithreaded-connection)
+				  (id (eql :repl-thread)))
+  (find-repl-thread connection))
+
+(defun find-repl-thread (connection)
+  (cond ((not (use-threads-p))
+         (current-thread))
+        (t
+         (let ((thread (mconn.repl-thread connection)))
+           (cond ((not thread) nil)
+                 ((thread-alive-p thread) thread)
+                 (t
+                  (setf (mconn.repl-thread connection)
+                        (spawn-repl-thread connection "new-repl-thread"))))))))
+
+(defun spawn-repl-thread (connection name)
+  (spawn (lambda ()
+           (with-bindings *default-worker-thread-bindings*
+             (repl-loop connection)))
+         :name name))
+
+(defun repl-loop (connection)
+  (handle-requests connection))
+
+;;;;; Redirection during requests
+;;;
+;;; We always redirect the standard streams to Emacs while evaluating
+;;; an RPC. This is done with simple dynamic bindings.
+
+(defslimefun create-repl (target &key coding-system)
+  (assert (eq target nil))
+  (let ((conn *emacs-connection*))
+    (initialize-streams-for-connection conn `(:coding-system ,coding-system))
+    (with-struct* (connection. @ conn)
+      (setf (@ env)
+	    `((*standard-input*  . ,(@ user-input))
+	      ,@(unless (globally-redirect-io-p)
+		  `((*standard-output* . ,(@ user-output))
+		    (*trace-output*    . ,(or (@ trace-output) (@ user-output)))
+		    (*error-output*    . ,(@ user-output))
+		    (*debug-io*        . ,(@ user-io))
+		    (*query-io*        . ,(@ user-io))
+		    (*terminal-io*     . ,(@ user-io))))))
+      (maybe-redirect-global-io conn)
+      (add-hook *connection-closed-hook* 'update-redirection-after-close)
+      (typecase conn
+	(multithreaded-connection
+	 (setf (mconn.repl-thread conn)
+	       (spawn-repl-thread conn "repl-thread"))))
+      (list (package-name *package*)
+            (package-string-for-prompt *package*)))))
+
+(defun initialize-streams-for-connection (connection properties)
+  (multiple-value-bind (dedicated in out io repl-results)
+      (open-streams connection properties)
+    (setf (connection.dedicated-output connection) dedicated
+          (connection.user-io connection)          io
+          (connection.user-output connection)      out
+          (connection.user-input connection)       in
+          (connection.repl-results connection)     repl-results)
+    connection))
+
+(defun read-user-input-from-emacs ()
+  (let ((tag (make-tag)))
+    (force-output)
+    (send-to-emacs `(:read-string ,(current-thread-id) ,tag))
+    (let ((ok nil))
+      (unwind-protect
+           (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
+             (setq ok t))
+        (unless ok
+          (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))
+
+;;;;; Listener eval
+
+(defvar *listener-eval-function* 'repl-eval)
+
+(defvar *listener-saved-value* nil)
+
+(defslimefun listener-save-value (slimefun &rest args)
+  "Apply SLIMEFUN to ARGS and save the value.
+The saved value should be visible to all threads and retrieved via
+LISTENER-GET-VALUE."
+  (setq *listener-saved-value* (apply slimefun args))
+  t)
+
+(defslimefun listener-get-value ()
+  "Get the last value saved by LISTENER-SAVE-VALUE.
+The value should be produced as if it were requested through
+LISTENER-EVAL directly, so that spacial variables *, etc are set."
+  (listener-eval (let ((*package* (find-package :keyword)))
+                   (write-to-string '*listener-saved-value*))))
+
+(defslimefun listener-eval (string &key (window-width nil window-width-p))
+  (if window-width-p
+      (let ((*print-right-margin* window-width))
+        (funcall *listener-eval-function* string))
+      (funcall *listener-eval-function* string)))
+
+(defslimefun clear-repl-variables ()
+  (let ((variables '(*** ** * /// // / +++ ++ +)))
+    (loop for variable in variables
+       do (setf (symbol-value variable) nil))))
+
+(defvar *send-repl-results-function* 'send-repl-results-to-emacs)
+
+(defun repl-eval (string)
+  (clear-user-input)
+  (with-buffer-syntax ()
+    (with-retry-restart (:msg "Retry SLIME REPL evaluation request.")
+      (track-package
+       (lambda ()
+         (multiple-value-bind (values last-form) (eval-region string)
+           (setq *** **  ** *  * (car values)
+                 /// //  // /  / values
+                 +++ ++  ++ +  + last-form)
+           (funcall *send-repl-results-function* values))))))
+  nil)
+
+(defun track-package (fun)
+  (let ((p *package*))
+    (unwind-protect (funcall fun)
+      (unless (eq *package* p)
+        (send-to-emacs (list :new-package (package-name *package*)
+                             (package-string-for-prompt *package*)))))))
+
+(defun send-repl-results-to-emacs (values)
+  (finish-output)
+  (if (null values)
+      (send-to-emacs `(:write-string "; No value" :repl-result))
+      (dolist (v values)
+        (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
+                                       :repl-result)))))
+
+(defslimefun redirect-trace-output (target)
+  (setf (connection.trace-output *emacs-connection*)
+        (swank:make-output-stream-for-target *emacs-connection* target))
+  nil)
+
+
+
+;;;; IO to Emacs
+;;;
+;;; This code handles redirection of the standard I/O streams
+;;; (`*standard-output*', etc) into Emacs. The `connection' structure
+;;; contains the appropriate streams, so all we have to do is make the
+;;; right bindings.
+
+;;;;; Global I/O redirection framework
+;;;
+;;; Optionally, the top-level global bindings of the standard streams
+;;; can be assigned to be redirected to Emacs. When Emacs connects we
+;;; redirect the streams into the connection, and they keep going into
+;;; that connection even if more are established. If the connection
+;;; handling the streams closes then another is chosen, or if there
+;;; are no connections then we revert to the original (real) streams.
+;;;
+;;; It is slightly tricky to assign the global values of standard
+;;; streams because they are often shadowed by dynamic bindings. We
+;;; solve this problem by introducing an extra indirection via synonym
+;;; streams, so that *STANDARD-INPUT* is a synonym stream to
+;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
+;;; variables, so they can always be assigned to affect a global
+;;; change.
+
+;;;;; Global redirection setup
+
+(defvar *saved-global-streams* '()
+  "A plist to save and restore redirected stream objects.
+E.g. the value for '*standard-output* holds the stream object
+for *standard-output* before we install our redirection.")
+
+(defun setup-stream-indirection (stream-var &optional stream)
+  "Setup redirection scaffolding for a global stream variable.
+Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
+
+1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
+
+2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
+*STANDARD-INPUT*.
+
+3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
+*CURRENT-STANDARD-INPUT*.
+
+This has the effect of making *CURRENT-STANDARD-INPUT* contain the
+effective global value for *STANDARD-INPUT*. This way we can assign
+the effective global value even when *STANDARD-INPUT* is shadowed by a
+dynamic binding."
+  (let ((current-stream-var (prefixed-var '#:current stream-var))
+        (stream (or stream (symbol-value stream-var))))
+    ;; Save the real stream value for the future.
+    (setf (getf *saved-global-streams* stream-var) stream)
+    ;; Define a new variable for the effective stream.
+    ;; This can be reassigned.
+    (proclaim `(special ,current-stream-var))
+    (set current-stream-var stream)
+    ;; Assign the real binding as a synonym for the current one.
+    (let ((stream (make-synonym-stream current-stream-var)))
+      (set stream-var stream)
+      (set-default-initial-binding stream-var `(quote ,stream)))))
+
+(defun prefixed-var (prefix variable-symbol)
+  "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
+  (let ((basename (subseq (symbol-name variable-symbol) 1)))
+    (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
+
+(defvar *standard-output-streams*
+  '(*standard-output* *error-output* *trace-output*)
+  "The symbols naming standard output streams.")
+
+(defvar *standard-input-streams*
+  '(*standard-input*)
+  "The symbols naming standard input streams.")
+
+(defvar *standard-io-streams*
+  '(*debug-io* *query-io* *terminal-io*)
+  "The symbols naming standard io streams.")
+
+(defun init-global-stream-redirection ()
+  (when (globally-redirect-io-p)
+    (cond (*saved-global-streams*
+           (warn "Streams already redirected."))
+          (t
+           (mapc #'setup-stream-indirection
+                 (append *standard-output-streams*
+                         *standard-input-streams*
+                         *standard-io-streams*))))))
+
+(defun globally-redirect-io-to-connection (connection)
+  "Set the standard I/O streams to redirect to CONNECTION.
+Assigns *CURRENT-<STREAM>* for all standard streams."
+  (dolist (o *standard-output-streams*)
+    (set (prefixed-var '#:current o)
+         (connection.user-output connection)))
+  ;; FIXME: If we redirect standard input to Emacs then we get the
+  ;; regular Lisp top-level trying to read from our REPL.
+  ;;
+  ;; Perhaps the ideal would be for the real top-level to run in a
+  ;; thread with local bindings for all the standard streams. Failing
+  ;; that we probably would like to inhibit it from reading while
+  ;; Emacs is connected.
+  ;;
+  ;; Meanwhile we just leave *standard-input* alone.
+  #+NIL
+  (dolist (i *standard-input-streams*)
+    (set (prefixed-var '#:current i)
+         (connection.user-input connection)))
+  (dolist (io *standard-io-streams*)
+    (set (prefixed-var '#:current io)
+         (connection.user-io connection))))
+
+(defun revert-global-io-redirection ()
+  "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
+  (dolist (stream-var (append *standard-output-streams*
+                              *standard-input-streams*
+                              *standard-io-streams*))
+    (set (prefixed-var '#:current stream-var)
+         (getf *saved-global-streams* stream-var))))
+
+;;;;; Global redirection hooks
+
+(defvar *global-stdio-connection* nil
+  "The connection to which standard I/O streams are globally redirected.
+NIL if streams are not globally redirected.")
+
+(defun maybe-redirect-global-io (connection)
+  "Consider globally redirecting to CONNECTION."
+  (when (and (globally-redirect-io-p) (null *global-stdio-connection*)
+             (connection.user-io connection))
+    (unless *saved-global-streams*
+      (init-global-stream-redirection))
+    (setq *global-stdio-connection* connection)
+    (globally-redirect-io-to-connection connection)))
+
+(defun update-redirection-after-close (closed-connection)
+  "Update redirection after a connection closes."
+  (check-type closed-connection connection)
+  (when (eq *global-stdio-connection* closed-connection)
+    (if (and (default-connection) (globally-redirect-io-p))
+        ;; Redirect to another connection.
+        (globally-redirect-io-to-connection (default-connection))
+        ;; No more connections, revert to the real streams.
+        (progn (revert-global-io-redirection)
+               (setq *global-stdio-connection* nil)))))
+
+(provide :swank-repl)

sources_non_forked/slimv/slime/contrib/swank-sbcl-exts.lisp

@@ -0,0 +1,67 @@
+;;; swank-sbcl-exts.lisp --- Misc extensions for SBCL
+;;
+;; Authors: Tobias C. Rittweiler <tcr@freebits.de>
+;;
+;; License: Public Domain
+;;
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (swank-require :swank-arglists))
+
+;; We need to do this so users can place `slime-sbcl-exts' into their
+;; ~/.emacs, and still use any implementation they want.
+#+sbcl
+(progn
+  
+;;; Display arglist of instructions.
+;;;
+(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'sb-assem:inst))
+                                             argument-forms)
+  (flet ((decode-instruction-arglist (instr-name instr-arglist)
+           (let ((decoded-arglist (decode-arglist instr-arglist)))
+             ;; The arglist of INST is (instruction ...INSTR-ARGLIST...).
+             (push 'sb-assem::instruction (arglist.required-args decoded-arglist))
+             (values decoded-arglist
+                     (list instr-name)
+                     t))))
+    (if (null argument-forms)
+        (call-next-method)
+        (destructuring-bind (instruction &rest args) argument-forms
+          (declare (ignore args))
+          (let* ((instr-name
+                   (typecase instruction
+                     (arglist-dummy
+                      (string-upcase (arglist-dummy.string-representation instruction)))
+                     (symbol
+                      (string-downcase instruction))))
+                 (instr-fn
+                   #+#.(swank/backend:with-symbol 'op-encoder-name 'sb-assem)
+                   (or (sb-assem::op-encoder-name instr-name)
+                       (sb-assem::op-encoder-name (string-upcase instr-name)))
+                   #+#.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem)
+                   (sb-assem::inst-emitter-symbol instr-name)
+                   #+(and
+                      (not #.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem))
+                      #.(swank/backend:with-symbol '*assem-instructions* 'sb-assem))
+                   (gethash instr-name sb-assem:*assem-instructions*)))
+            (cond ((functionp instr-fn)
+                   (with-available-arglist (arglist) (arglist instr-fn)
+                     (decode-instruction-arglist instr-name arglist)))
+                  ((fboundp instr-fn)
+                   (with-available-arglist (arglist) (arglist instr-fn)
+                     ;; SB-ASSEM:INST invokes a symbolic INSTR-FN with
+                     ;; current segment and current vop implicitly.
+                     (decode-instruction-arglist instr-name
+                                                 (if (or (get instr-fn :macro)
+                                                         (macro-function instr-fn))
+                                                     arglist
+                                                     (cddr arglist)))))
+                  (t
+                   (call-next-method))))))))
+
+
+) ; PROGN
+
+(provide :swank-sbcl-exts)

sources_non_forked/slimv/slime/contrib/swank-snapshot.lisp

@@ -0,0 +1,67 @@
+
+(defpackage swank-snapshot
+  (:use cl)
+  (:export restore-snapshot save-snapshot background-save-snapshot)
+  (:import-from swank defslimefun))
+(in-package swank-snapshot)
+
+(defslimefun save-snapshot (image-file)
+  (swank/backend:save-image image-file 
+			    (let ((c swank::*emacs-connection*))
+			      (lambda () (resurrect c))))
+  (format nil "Dumped lisp to ~A" image-file))
+
+(defslimefun restore-snapshot (image-file)
+  (let* ((conn swank::*emacs-connection*)
+	 (stream (swank::connection.socket-io conn))
+	 (clone (swank/backend:dup (swank/backend:socket-fd stream)))
+	 (style (swank::connection.communication-style conn))
+	 (repl (if (swank::connection.user-io conn) t))
+	 (args (list "--swank-fd" (format nil "~d" clone)
+		     "--swank-style" (format nil "~s" style)
+		     "--swank-repl" (format nil "~s" repl))))
+    (swank::close-connection conn nil nil)
+    (swank/backend:exec-image image-file args)))
+
+(defslimefun background-save-snapshot (image-file)
+  (let ((connection swank::*emacs-connection*))
+    (flet ((complete (success)
+	     (let ((swank::*emacs-connection* connection))
+	       (swank::background-message
+		"Dumping lisp image ~A ~:[failed!~;succeeded.~]" 
+		image-file success)))
+	   (awaken ()
+	     (resurrect connection)))
+      (swank/backend:background-save-image image-file
+					   :restart-function #'awaken
+					   :completion-function #'complete)
+      (format nil "Started dumping lisp to ~A..." image-file))))
+
+(in-package :swank)
+
+(defun swank-snapshot::resurrect (old-connection)
+  (setq *log-output* nil)
+  (init-log-output)
+  (clear-event-history)
+  (setq *connections* (delete old-connection *connections*))
+  (format *error-output* "args: ~s~%" (command-line-args))
+  (let* ((fd (read-command-line-arg "--swank-fd"))
+	 (style (read-command-line-arg "--swank-style"))
+	 (repl (read-command-line-arg "--swank-repl"))
+	 (* (format *error-output* "fd=~s style=~s~%" fd style))
+	 (stream (make-fd-stream fd nil))
+	 (connection (make-connection nil stream style)))
+    (let ((*emacs-connection* connection))
+      (when repl (swank-repl:create-repl nil))
+      (background-message "~A" "Lisp image restored"))
+    (serve-requests connection)
+    (simple-repl)))
+
+(defun read-command-line-arg (name)
+  (let* ((args (command-line-args))
+	 (pos (position name args :test #'equal)))
+    (read-from-string (elt args (1+ pos)))))
+
+(in-package :swank-snapshot)
+
+(provide :swank-snapshot)

sources_non_forked/slimv/slime/contrib/swank-sprof.lisp

@@ -0,0 +1,154 @@
+;;; swank-sprof.lisp
+;;
+;; Authors: Juho Snellman
+;;
+;; License: MIT
+;;
+
+(in-package :swank)
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :sb-sprof))
+
+#+sbcl(progn
+
+(defvar *call-graph* nil)
+(defvar *node-numbers* nil)
+(defvar *number-nodes* nil)
+
+(defun frame-name (name)
+  (if (consp name)
+      (case (first name)
+        ((sb-c::xep sb-c::tl-xep
+                    sb-c::&more-processor
+                    sb-c::top-level-form
+                    sb-c::&optional-processor)
+         (second name))
+        (sb-pcl::fast-method
+         (cdr name))
+        ((flet labels lambda)
+         (let* ((in (member :in name)))
+           (if (stringp (cadr in))
+               (append (ldiff name in) (cddr in))
+               name)))
+        (t
+         name))
+      name))
+
+(defun pretty-name (name)
+  (let ((*package* (find-package :common-lisp-user))
+        (*print-right-margin* most-positive-fixnum))
+    (format nil "~S" (frame-name name))))
+
+(defun samples-percent (count)
+  (sb-sprof::samples-percent *call-graph* count))
+
+(defun node-values (node)
+  (values (pretty-name (sb-sprof::node-name node))
+          (samples-percent (sb-sprof::node-count node))
+          (samples-percent (sb-sprof::node-accrued-count node))))
+
+(defun filter-swank-nodes (nodes)
+  (let ((swank-packages (load-time-value
+                         (mapcar #'find-package
+                                 '(swank swank/rpc swank/mop
+                                   swank/match swank/backend)))))
+    (remove-if (lambda (node)
+                 (let ((name (sb-sprof::node-name node)))
+                   (and (symbolp name)
+                        (member (symbol-package name) swank-packages
+                                :test #'eq))))
+               nodes)))
+
+(defun serialize-call-graph (&key exclude-swank)
+  (let ((nodes (sb-sprof::call-graph-flat-nodes *call-graph*)))
+    (when exclude-swank
+      (setf nodes (filter-swank-nodes nodes)))
+    (setf nodes (sort (copy-list nodes) #'>
+                      ;; :key #'sb-sprof::node-count)))
+                      :key #'sb-sprof::node-accrued-count))
+    (setf *number-nodes* (make-hash-table))
+    (setf *node-numbers* (make-hash-table))
+    (loop for node in nodes
+          for i from 1
+          with total = 0
+          collect (multiple-value-bind (name self cumulative)
+                      (node-values node)
+                    (setf (gethash node *node-numbers*) i
+                          (gethash i *number-nodes*) node)
+                    (incf total self)
+                    (list i name self cumulative total)) into list
+          finally (return
+                    (let ((rest (- 100 total)))
+                      (return (append list
+                                      `((nil "Elsewhere" ,rest nil nil)))))))))
+
+(defslimefun swank-sprof-get-call-graph (&key exclude-swank)
+  (when (setf *call-graph* (sb-sprof:report :type nil))
+    (serialize-call-graph :exclude-swank exclude-swank)))
+
+(defslimefun swank-sprof-expand-node (index)
+  (let* ((node (gethash index *number-nodes*)))
+    (labels ((caller-count (v)
+               (loop for e in (sb-sprof::vertex-edges v) do
+                     (when (eq (sb-sprof::edge-vertex e) node)
+                       (return-from caller-count (sb-sprof::call-count e))))
+               0)
+             (serialize-node (node count)
+               (etypecase node
+                 (sb-sprof::cycle
+                  (list (sb-sprof::cycle-index node)
+                        (sb-sprof::cycle-name node)
+                        (samples-percent count)))
+                 (sb-sprof::node
+                  (let ((name (node-values node)))
+                    (list (gethash node *node-numbers*)
+                          name
+                          (samples-percent count)))))))
+      (list :callers (loop for node in
+                           (sort (copy-list (sb-sprof::node-callers node)) #'>
+                                 :key #'caller-count)
+                           collect (serialize-node node
+                                                   (caller-count node)))
+            :calls (let ((edges (sort (copy-list (sb-sprof::vertex-edges node))
+                                      #'>
+                                      :key #'sb-sprof::call-count)))
+                     (loop for edge in edges
+                           collect
+                           (serialize-node (sb-sprof::edge-vertex edge)
+                                           (sb-sprof::call-count edge))))))))
+
+(defslimefun swank-sprof-disassemble (index)
+  (let* ((node (gethash index *number-nodes*))
+         (debug-info (sb-sprof::node-debug-info node)))
+    (with-output-to-string (s)
+      (typecase debug-info
+        (sb-impl::code-component
+         (sb-disassem::disassemble-memory (sb-vm::code-instructions debug-info)
+                                          (sb-vm::%code-code-size debug-info)
+                                          :stream s))
+        (sb-di::compiled-debug-fun
+         (let ((component (sb-di::compiled-debug-fun-component debug-info)))
+           (sb-disassem::disassemble-code-component component :stream s)))
+        (t `(:error "No disassembly available"))))))
+
+(defslimefun swank-sprof-source-location (index)
+  (let* ((node (gethash index *number-nodes*))
+         (debug-info (sb-sprof::node-debug-info node)))
+    (or (when (typep debug-info 'sb-di::compiled-debug-fun)
+          (let* ((component (sb-di::compiled-debug-fun-component debug-info))
+                 (function (sb-kernel::%code-entry-points component)))
+            (when function
+              (find-source-location function))))
+        `(:error "No source location available"))))
+
+(defslimefun swank-sprof-start (&key (mode :cpu))
+  (sb-sprof:start-profiling :mode mode))
+
+(defslimefun swank-sprof-stop ()
+  (sb-sprof:stop-profiling))
+
+)
+
+(provide :swank-sprof)

sources_non_forked/slimv/slime/contrib/swank-trace-dialog.lisp

@@ -0,0 +1,264 @@
+(defpackage :swank-trace-dialog
+  (:use :cl)
+  (:import-from :swank :defslimefun :from-string :to-string)
+  (:export #:clear-trace-tree
+           #:dialog-toggle-trace
+           #:dialog-trace
+           #:dialog-traced-p
+           #:dialog-untrace
+           #:dialog-untrace-all
+           #:inspect-trace-part
+           #:report-partial-tree
+           #:report-specs
+           #:report-total
+           #:report-trace-detail
+           #:report-specs
+           #:trace-format
+           #:still-inside
+           #:exited-non-locally
+           #:*record-backtrace*
+           #:*traces-per-report*
+           #:*dialog-trace-follows-trace*
+           #:find-trace-part
+           #:find-trace))
+
+(in-package :swank-trace-dialog)
+
+(defparameter *record-backtrace* nil
+  "Record a backtrace of the last 20 calls for each trace.
+
+Beware that this may have a drastic performance impact on your
+program.")
+
+(defparameter *traces-per-report* 150
+  "Number of traces to report to emacs in each batch.")
+
+
+;;;; `trace-entry' model
+;;;;
+(defvar *traces* (make-array 1000 :fill-pointer 0
+                                  :adjustable t))
+
+(defvar *trace-lock* (swank/backend:make-lock :name "swank-trace-dialog lock"))
+
+(defvar *current-trace-by-thread* (make-hash-table))
+
+(defclass trace-entry ()
+  ((id         :reader   id-of)
+   (children   :accessor children-of :initform nil)
+   (backtrace  :accessor backtrace-of :initform (when *record-backtrace*
+                                                  (useful-backtrace)))
+
+   (spec       :initarg  :spec      :accessor spec-of
+               :initform (error "must provide a spec"))
+   (args       :initarg  :args      :accessor args-of
+               :initform (error "must provide args"))
+   (parent     :initarg  :parent    :reader   parent-of
+               :initform (error "must provide a parent, even if nil"))
+   (retlist    :initarg  :retlist   :accessor retlist-of
+               :initform 'still-inside)))
+
+(defmethod initialize-instance :after ((entry trace-entry) &rest initargs)
+  (declare (ignore initargs))
+  (if (parent-of entry)
+      (nconc (children-of (parent-of entry)) (list entry)))
+  (swank/backend:call-with-lock-held
+   *trace-lock*
+   #'(lambda ()
+       (setf (slot-value entry 'id) (fill-pointer *traces*))
+       (vector-push-extend entry *traces*))))
+
+(defmethod print-object ((entry trace-entry) stream)
+  (print-unreadable-object (entry stream)
+    (format stream "~a: ~a" (id-of entry) (spec-of entry))))
+
+(defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside)))
+
+(defun find-trace (id)
+  (when (<= 0 id (1- (length *traces*)))
+    (aref *traces* id)))
+
+(defun find-trace-part (id part-id type)
+  (let* ((trace (find-trace id))
+         (l (and trace
+                 (ecase type
+                   (:arg (args-of trace))
+                   (:retval (swank::ensure-list (retlist-of trace)))))))
+    (values (nth part-id l)
+            (< part-id (length l)))))
+
+(defun useful-backtrace ()
+  (swank/backend:call-with-debugging-environment
+   #'(lambda ()
+       (loop for i from 0
+             for frame in (swank/backend:compute-backtrace 0 20)
+             collect (list i (swank::frame-to-string frame))))))
+
+(defun current-trace ()
+  (gethash (swank/backend:current-thread) *current-trace-by-thread*))
+
+(defun (setf current-trace) (trace)
+  (setf (gethash (swank/backend:current-thread) *current-trace-by-thread*)
+        trace))
+
+
+;;;; Control of traced specs
+;;;
+(defvar *traced-specs* '())
+
+(defslimefun dialog-trace (spec)
+  (flet ((before-hook (args)
+           (setf (current-trace) (make-instance 'trace-entry
+                                                :spec      spec
+                                                :args      args
+                                                :parent    (current-trace))))
+         (after-hook (retlist)
+           (let ((trace (current-trace)))
+             (when trace
+               ;; the current trace might have been wiped away if the
+               ;; user cleared the tree in the meantime. no biggie,
+               ;; don't do anything.
+               ;;
+               (setf (retlist-of trace) retlist
+                     (current-trace) (parent-of trace))))))
+    (when (dialog-traced-p spec)
+      (warn "~a is apparently already traced! Untracing and retracing." spec)
+      (dialog-untrace spec))
+    (swank/backend:wrap spec 'trace-dialog
+                        :before #'before-hook
+                        :after #'after-hook)
+    (pushnew spec *traced-specs*)
+    (format nil "~a is now traced for trace dialog" spec)))
+
+(defslimefun dialog-untrace (spec)
+  (swank/backend:unwrap spec 'trace-dialog)
+  (setq *traced-specs* (remove spec *traced-specs* :test #'equal))
+  (format nil "~a is now untraced for trace dialog" spec))
+
+(defslimefun dialog-toggle-trace (spec)
+  (if (dialog-traced-p spec)
+      (dialog-untrace spec)
+      (dialog-trace spec)))
+
+(defslimefun dialog-traced-p (spec)
+  (find spec *traced-specs* :test #'equal))
+
+(defslimefun dialog-untrace-all ()
+  (untrace)
+  (mapcar #'dialog-untrace *traced-specs*))
+
+(defparameter *dialog-trace-follows-trace* nil)
+
+(setq swank:*after-toggle-trace-hook*
+      #'(lambda (spec traced-p)
+          (when *dialog-trace-follows-trace*
+            (cond (traced-p
+                   (dialog-trace spec)
+                   "traced for trace dialog as well")
+                  (t
+                   (dialog-untrace spec)
+                   "untraced for the trace dialog as well")))))
+
+
+;;;; A special kind of trace call
+;;;
+(defun trace-format (format-spec &rest format-args)
+  "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace."
+  (let* ((line (apply #'format nil format-spec format-args)))
+    (make-instance 'trace-entry :spec line
+                                :args format-args
+                                :parent (current-trace)
+                                :retlist nil)))
+
+
+;;;; Reporting to emacs
+;;;
+(defparameter *visitor-idx* 0)
+
+(defparameter *visitor-key* nil)
+
+(defvar *unfinished-traces* '())
+
+(defun describe-trace-for-emacs (trace)
+  `(,(id-of trace)
+    ,(and (parent-of trace) (id-of (parent-of trace)))
+    ,(spec-of trace)
+    ,(loop for arg in (args-of trace)
+           for i from 0
+           collect (list i (swank::to-line arg)))
+    ,(loop for retval in (swank::ensure-list (retlist-of trace))
+           for i from 0
+           collect (list i (swank::to-line retval)))))
+
+(defslimefun report-partial-tree (key)
+  (unless (equal key *visitor-key*)
+    (setq *visitor-idx* 0
+          *visitor-key* key))
+  (let* ((recently-finished
+           (loop with i = 0
+                 for trace in *unfinished-traces*
+                 while (< i *traces-per-report*)
+                 when (completed-p trace)
+                   collect trace
+                   and do
+                     (incf i)
+                     (setq *unfinished-traces*
+                           (remove trace *unfinished-traces*))))
+         (new (loop for i
+                      from (length recently-finished)
+                        below *traces-per-report*
+                    while (< *visitor-idx* (length *traces*))
+                    for trace = (aref *traces* *visitor-idx*)
+                    collect trace
+                    unless (completed-p trace)
+                      do (push trace *unfinished-traces*)
+                    do (incf *visitor-idx*))))
+    (list
+     (mapcar #'describe-trace-for-emacs
+             (append recently-finished new))
+     (- (length *traces*) *visitor-idx*)
+    key)))
+
+(defslimefun report-trace-detail (trace-id)
+  (swank::call-with-bindings
+   swank::*inspector-printer-bindings*
+   #'(lambda ()
+       (let ((trace (find-trace trace-id)))
+         (when trace
+           (append
+            (describe-trace-for-emacs trace)
+            (list (backtrace-of trace)
+                  (swank::to-line trace))))))))
+
+(defslimefun report-specs ()
+  (sort (copy-list *traced-specs*)
+        #'string<
+        :key #'princ-to-string))
+
+(defslimefun report-total ()
+  (length *traces*))
+
+(defslimefun clear-trace-tree ()
+  (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*)
+        *visitor-key* nil
+        *unfinished-traces* nil)
+  (swank/backend:call-with-lock-held
+   *trace-lock*
+   #'(lambda () (setf (fill-pointer *traces*) 0)))
+  nil)
+
+;; HACK: `swank::*inspector-history*' is unbound by default and needs
+;; a reset in that case so that it won't error `swank::inspect-object'
+;; before any other object is inspected in the slime session.
+;;
+(unless (boundp 'swank::*inspector-history*)
+  (swank::reset-inspector))
+
+(defslimefun inspect-trace-part (trace-id part-id type)
+  (multiple-value-bind (obj found)
+      (find-trace-part trace-id part-id type)
+    (if found
+        (swank::inspect-object obj)
+        (error "No object found with ~a, ~a and ~a" trace-id part-id type))))
+
+(provide :swank-trace-dialog)

sources_non_forked/slimv/slime/contrib/swank-util.lisp

@@ -0,0 +1,63 @@
+;;; swank-util.lisp --- stuff of questionable utility
+;;
+;; License: public domain
+
+(in-package :swank)
+
+(defmacro do-symbols* ((var &optional (package '*package*) result-form)
+                       &body body)
+  "Just like do-symbols, but makes sure a symbol is visited only once."
+  (let ((seen-ht (gensym "SEEN-HT")))
+    `(let ((,seen-ht (make-hash-table :test #'eq)))
+       (do-symbols (,var ,package ,result-form)
+         (unless (gethash ,var ,seen-ht)
+           (setf (gethash ,var ,seen-ht) t)
+           (tagbody ,@body))))))
+
+(defun classify-symbol (symbol)
+  "Returns a list of classifiers that classify SYMBOL according to its
+underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special
+variable.) The list may contain the following classification
+keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
+:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
+  (check-type symbol symbol)
+  (flet ((type-specifier-p (s)
+           (or (documentation s 'type)
+               (not (eq (type-specifier-arglist s) :not-available)))))
+    (let (result)
+      (when (boundp symbol)             (push (if (constantp symbol)
+                                                  :constant :boundp) result))
+      (when (fboundp symbol)            (push :fboundp result))
+      (when (type-specifier-p symbol)   (push :typespec result))
+      (when (find-class symbol nil)     (push :class result))
+      (when (macro-function symbol)     (push :macro result))
+      (when (special-operator-p symbol) (push :special-operator result))
+      (when (find-package symbol)       (push :package result))
+      (when (and (fboundp symbol)
+                 (typep (ignore-errors (fdefinition symbol))
+                        'generic-function))
+        (push :generic-function result))
+      result)))
+
+(defun symbol-classification-string (symbol)
+  "Return a string in the form -f-c---- where each letter stands for
+boundp fboundp generic-function class macro special-operator package"
+  (let ((letters "bfgctmsp")
+        (result (copy-seq "--------")))
+    (flet ((flip (letter)
+             (setf (char result (position letter letters))
+                   letter)))
+      (when (boundp symbol) (flip #\b))
+      (when (fboundp symbol)
+        (flip #\f)
+        (when (typep (ignore-errors (fdefinition symbol))
+                     'generic-function)
+          (flip #\g)))
+      (when (type-specifier-p symbol) (flip #\t))
+      (when (find-class symbol nil)   (flip #\c) )
+      (when (macro-function symbol)   (flip #\m))
+      (when (special-operator-p symbol) (flip #\s))
+      (when (find-package symbol)       (flip #\p))
+      result)))
+
+(provide :swank-util)