Add support for Scheme and Racket language.

sources_non_forked/slimv/slime/README.md

@@ -0,0 +1,64 @@
+[![Build Status](https://github.com/slime/slime/workflows/CI/badge.svg)](https://github.com/slime/slime/actions)
+[![MELPA](http://melpa.org/packages/slime-badge.svg?)](http://melpa.org/#/slime) [![MELPA Stable](http://stable.melpa.org/packages/slime-badge.svg?)](http://stable.melpa.org/#/slime)
+
+Overview
+--------
+
+SLIME is the Superior Lisp Interaction Mode for Emacs.
+
+SLIME extends Emacs with support for interactive programming in Common
+Lisp. The features are centered around slime-mode, an Emacs minor-mode that
+complements the standard lisp-mode. While lisp-mode supports editing Lisp
+source files, slime-mode adds support for interacting with a running Common
+Lisp process for compilation, debugging, documentation lookup, and so on.
+
+For much more information, consult [the manual][1].
+
+
+Quick setup instructions
+------------------------
+
+  1. [Set up the MELPA repository][2], if you haven't already, and install
+     SLIME using `M-x package-install RET slime RET`.
+
+  2. In your `~/.emacs` file, point the `inferior-lisp-program`
+     variable to your favourite Common Lisp implementation:
+
+     ```el
+     (setq inferior-lisp-program "sbcl")
+     ```
+
+  3. Use `M-x slime` to fire up and connect to an inferior Lisp. SLIME will
+     now automatically be available in your Lisp source buffers.
+
+If you'd like to contribute to SLIME, you will want to instead follow
+the manual's instructions on [how to install SLIME via Git][7].
+
+
+License
+-------
+
+SLIME is free software. All files, unless explicitly stated otherwise, are
+public domain.
+
+
+Contact
+-------
+
+If you have problems, first have a look at the list of
+[known issues and workarounds][6]. 
+
+Questions and comments are best directed to the mailing list at
+`slime-devel@common-lisp.net`, but you have to [subscribe][3] first.
+
+See the [CONTRIBUTING.md][5] file for instructions on how to contribute.
+
+
+
+
+[1]: http://common-lisp.net/project/slime/doc/html/
+[2]: http://melpa.org/#/getting-started
+[3]: http://www.common-lisp.net/project/slime/#mailinglist
+[5]: https://github.com/slime/slime/blob/master/CONTRIBUTING.md
+[6]: https://github.com/slime/slime/issues?labels=workaround&state=closed
+[7]: http://common-lisp.net/project/slime/doc/html/Installation.html#Installing-from-Git

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)

sources_non_forked/slimv/slime/nregex.lisp

@@ -0,0 +1,523 @@
+;;;
+;;; This code was written by:
+;;;
+;;;    Lawrence E. Freil <lef@freil.com>
+;;;    National Science Center Foundation
+;;;    Augusta, Georgia 30909
+;;;
+;;; This program was released into the public domain on 2005-08-31.
+;;; (See the slime-devel mailing list archive for details.)
+;;;
+;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression
+;;;               parser. 
+;;;
+;;;               This regular expression parser operates by taking a
+;;;               regular expression and breaking it down into a list
+;;;               consisting of lisp expressions and flags.  The list
+;;;               of lisp expressions is then taken in turned into a
+;;;               lambda expression that can be later applied to a
+;;;               string argument for parsing.
+;;;;
+;;;; Modifications made 6 March 2001 By Chris Double (chris@double.co.nz)
+;;;; to get working with Corman Lisp 1.42, add package statement and export
+;;;; relevant functions.
+;;;;
+
+(in-package :cl-user)
+
+;; Renamed to slime-nregex avoid name clashes with other versions of
+;; this file. -- he
+
+;;;; CND - 6/3/2001
+(defpackage slime-nregex
+  (:use #:common-lisp)
+  (:export 
+   #:regex
+   #:regex-compile
+  ))
+
+;;;; CND - 6/3/2001
+(in-package :slime-nregex)
+
+;;;
+;;; First we create a copy of macros to help debug the beast
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defvar *regex-debug* nil)		; Set to nil for no debugging code
+)
+
+(defmacro info (message &rest args)
+  (if *regex-debug*
+      `(format *standard-output* ,message ,@args)))
+
+;;;
+;;; Declare the global variables for storing the paren index list.
+;;;
+(defvar *regex-groups* (make-array 10))
+(defvar *regex-groupings* 0)
+
+;;;
+;;; Declare a simple interface for testing.  You probably wouldn't want
+;;; to use this interface unless you were just calling this once.
+;;;
+(defun regex (expression string)
+  "Usage: (regex <expression> <string)
+   This function will call regex-compile on the expression and then apply
+   the string to the returned lambda list."
+  (let ((findit (cond ((stringp expression)
+		       (regex-compile expression))
+		      ((listp expression)
+		       expression)))
+	(result nil))
+    (if (not (funcall (if (functionp findit)
+			  findit
+			(eval `(function ,findit))) string))
+	(return-from regex nil))
+    (if (= *regex-groupings* 0)
+	(return-from regex t))
+    (dotimes (i *regex-groupings*)
+      (push (funcall 'subseq 
+		     string 
+		     (car (aref *regex-groups* i))
+		     (cadr (aref *regex-groups* i)))
+	    result))
+    (reverse result)))
+
+;;;
+;;; Declare some simple macros to make the code more readable.
+;;;
+(defvar *regex-special-chars* "?*+.()[]\\${}")
+
+(defmacro add-exp (list)
+  "Add an item to the end of expression"
+  `(setf expression (append expression ,list)))
+
+;;;
+;;; Define a function that will take a quoted character and return
+;;; what the real character should be plus how much of the source
+;;; string was used.  If the result is a set of characters, return an
+;;; array of bits indicating which characters should be set.  If the
+;;; expression is one of the sub-group matches return a
+;;; list-expression that will provide the match.  
+;;;
+(defun regex-quoted (char-string &optional (invert nil))
+  "Usage: (regex-quoted <char-string> &optional invert)
+       Returns either the quoted character or a simple bit vector of bits set for
+       the matching values"
+  (let ((first (char char-string 0))
+	(result (char char-string 0))
+	(used-length 1))
+    (cond ((eql first #\n)
+	   (setf result #\NewLine))
+	  ((eql first #\c)
+	   (setf result #\Return))
+	  ((eql first #\t)
+	   (setf result #\Tab))
+	  ((eql first #\d)
+	   (setf result #*0000000000000000000000000000000000000000000000001111111111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+	  ((eql first #\D)
+	   (setf result #*1111111111111111111111111111111111111111111111110000000000111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+	  ((eql first #\w)
+	   (setf result #*0000000000000000000000000000000000000000000000001111111111000000011111111111111111111111111000010111111111111111111111111110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+	  ((eql first #\W)
+	   (setf result #*1111111111111111111111111111111111111111111111110000000000111111100000000000000000000000000111101000000000000000000000000001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+	  ((eql first #\b)
+	   (setf result #*0000000001000000000000000000000011000000000010100000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+	  ((eql first #\B)
+	   (setf result #*1111111110111111111111111111111100111111111101011111111111011111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+	  ((eql first #\s)
+	   (setf result #*0000000001100000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+	  ((eql first #\S)
+	   (setf result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+	  ((and (>= (char-code first) (char-code #\0))
+		(<= (char-code first) (char-code #\9)))
+	   (if (and (> (length char-string) 2)
+		    (and (>= (char-code (char char-string 1)) (char-code #\0))
+			 (<= (char-code (char char-string 1)) (char-code #\9))
+			 (>= (char-code (char char-string 2)) (char-code #\0))
+			 (<= (char-code (char char-string 2)) (char-code #\9))))
+	       ;;
+	       ;; It is a single character specified in octal
+	       ;;
+	       (progn 
+		 (setf result (do ((x 0 (1+ x))
+				   (return 0))
+				  ((= x 2) return)
+				(setf return (+ (* return 8)
+						(- (char-code (char char-string x))
+						   (char-code #\0))))))
+		 (setf used-length 3))
+	     ;;
+	     ;; We have a group number replacement.
+	     ;;
+	     (let ((group (- (char-code first) (char-code #\0))))
+	       (setf result `((let ((nstring (subseq string (car (aref *regex-groups* ,group))
+						     (cadr (aref *regex-groups* ,group)))))
+				(if (< length (+ index (length nstring)))
+				    (return-from compare nil))
+				(if (not (string= string nstring
+						  :start1 index
+						  :end1 (+ index (length nstring))))
+				    (return-from compare nil)
+				  (incf index (length nstring)))))))))
+	  (t 
+	   (setf result first)))
+    (if (and (vectorp result) invert)
+	(bit-xor result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 t))
+    (values result used-length)))
+
+;;;
+;;; Now for the main regex compiler routine.
+;;;
+(defun regex-compile (source &key (anchored nil))
+  "Usage: (regex-compile <expression> [ :anchored (t/nil) ])
+       This function take a regular expression (supplied as source) and
+       compiles this into a lambda list that a string argument can then
+       be applied to.  It is also possible to compile this lambda list
+       for better performance or to save it as a named function for later
+       use"
+  (info "Now entering regex-compile with \"~A\"~%" source)
+  ;;
+  ;; This routine works in two parts.
+  ;; The first pass take the regular expression and produces a list of 
+  ;; operators and lisp expressions for the entire regular expression.  
+  ;; The second pass takes this list and produces the lambda expression.
+  (let ((expression '())		; holder for expressions
+	(group 1)			; Current group index
+	(group-stack nil)		; Stack of current group endings
+	(result nil)			; holder for built expression.
+	(fast-first nil))		; holder for quick unanchored scan
+    ;;
+    ;; If the expression was an empty string then it alway
+    ;; matches (so lets leave early)
+    ;;
+    (if (= (length source) 0)
+	(return-from regex-compile
+		     '(lambda (&rest args)
+			(declare (ignore args))
+			t)))
+    ;;
+    ;; If the first character is a caret then set the anchored
+    ;; flags and remove if from the expression string.
+    ;;
+    (cond ((eql (char source 0) #\^)
+	   (setf source (subseq source 1))
+	   (setf anchored t)))
+    ;;
+    ;; If the first sequence is .* then also set the anchored flags.
+    ;; (This is purely for optimization, it will work without this).
+    ;;
+    (if (>= (length source) 2)
+	(if (string= source ".*" :start1 0 :end1 2)
+	    (setf anchored t)))
+    ;;
+    ;; Also, If this is not an anchored search and the first character is
+    ;; a literal, then do a quick scan to see if it is even in the string.
+    ;; If not then we can issue a quick nil, 
+    ;; otherwise we can start the search at the matching character to skip
+    ;; the checks of the non-matching characters anyway.
+    ;;
+    ;; If I really wanted to speed up this section of code it would be 
+    ;; easy to recognize the case of a fairly long multi-character literal
+    ;; and generate a Boyer-Moore search for the entire literal. 
+    ;;
+    ;; I generate the code to do a loop because on CMU Lisp this is about
+    ;; twice as fast a calling position.
+    ;;
+    (if (and (not anchored)
+	     (not (position (char source 0) *regex-special-chars*))
+	     (not (and (> (length source) 1)
+		       (position (char source 1) *regex-special-chars*))))
+	(setf fast-first `((if (not (dotimes (i length nil)
+				     (if (eql (char string i)
+					      ,(char source 0))
+					 (return (setf start i)))))
+			      (return-from final-return nil)))))
+    ;;
+    ;; Generate the very first expression to save the starting index
+    ;; so that group 0 will be the entire string matched always
+    ;;
+    (add-exp '((setf (aref *regex-groups* 0)
+		     (list index nil))))
+    ;;
+    ;; Loop over each character in the regular expression building the
+    ;; expression list as we go.
+    ;;
+    (do ((eindex 0 (1+ eindex)))
+	((= eindex (length source)))
+      (let ((current (char source eindex)))
+	(info "Now processing character ~A index = ~A~%" current eindex)
+	(case current
+	  ((#\.)
+	   ;;
+	   ;; Generate code for a single wild character
+	   ;;
+	   (add-exp '((if (>= index length)
+			  (return-from compare nil)
+			(incf index)))))
+	  ((#\$)
+	   ;;
+	   ;; If this is the last character of the expression then
+	   ;; anchor the end of the expression, otherwise let it slide
+	   ;; as a standard character (even though it should be quoted).
+	   ;;
+	   (if (= eindex (1- (length source)))
+	       (add-exp '((if (not (= index length))
+			      (return-from compare nil))))
+	     (add-exp '((if (not (and (< index length)
+				      (eql (char string index) #\$)))
+			    (return-from compare nil)
+			  (incf index))))))
+	  ((#\*)
+	   (add-exp '(ASTRISK)))
+
+	  ((#\+)
+	   (add-exp '(PLUS)))
+
+	  ((#\?)
+	   (add-exp '(QUESTION)))
+
+	  ((#\()
+	   ;;
+	   ;; Start a grouping.
+	   ;;
+	   (incf group)
+	   (push group group-stack)
+	   (add-exp `((setf (aref *regex-groups* ,(1- group)) 
+			    (list index nil))))
+	   (add-exp `(,group)))
+	  ((#\))
+	   ;;
+	   ;; End a grouping
+	   ;;
+	   (let ((group (pop group-stack)))
+	     (add-exp `((setf (cadr (aref *regex-groups* ,(1- group)))
+			      index)))
+	     (add-exp `(,(- group)))))
+	  ((#\[)
+	   ;;
+	   ;; Start of a range operation.
+	   ;; Generate a bit-vector that has one bit per possible character
+	   ;; and then on each character or range, set the possible bits.
+	   ;;
+	   ;; If the first character is carat then invert the set.
+	   (let* ((invert (eql (char source (1+ eindex)) #\^))
+		  (bitstring (make-array 256 :element-type 'bit
+					     :initial-element
+					        (if invert 1 0)))
+		  (set-char (if invert 0 1)))
+	     (if invert (incf eindex))
+	     (do ((x (1+ eindex) (1+ x)))
+		 ((eql (char source x) #\]) (setf eindex x))
+	       (info "Building range with character ~A~%" (char source x))
+	       (cond ((and (eql (char source (1+ x)) #\-)
+			   (not (eql (char source (+ x 2)) #\])))
+		      (if (>= (char-code (char source x))
+			     (char-code (char source (+ 2 x))))
+			  (error "Invalid range \"~A-~A\".  Ranges must be in acending order"
+				 (char source x) (char source (+ 2 x))))
+		      (do ((j (char-code (char source x)) (1+ j)))
+		       ((> j (char-code (char source (+ 2 x))))
+			(incf x 2))
+		     (info "Setting bit for char ~A code ~A~%" (code-char j) j)
+		     (setf (sbit bitstring j) set-char)))
+		     (t
+		      (cond ((not (eql (char source x) #\]))
+			     (let ((char (char source x)))
+			       ;;
+			       ;; If the character is quoted then find out what
+			       ;; it should have been
+			       ;;
+			       (if (eql (char source x) #\\ )
+				   (let ((length))
+				     (multiple-value-setq (char length)
+					 (regex-quoted (subseq source x) invert))
+				     (incf x length)))
+			       (info "Setting bit for char ~A code ~A~%" char (char-code char))
+			       (if (not (vectorp char))
+				   (setf (sbit bitstring (char-code (char source x))) set-char)
+				 (bit-ior bitstring char t))))))))
+	     (add-exp `((let ((range ,bitstring))
+			  (if (>= index length)
+			      (return-from compare nil))
+			  (if (= 1 (sbit range (char-code (char string index))))
+			      (incf index)
+			    (return-from compare nil)))))))
+	  ((#\\ )
+	   ;;
+	   ;; Intreprete the next character as a special, range, octal, group or 
+           ;; just the character itself.
+	   ;;
+	   (let ((length)
+		 (value))
+	     (multiple-value-setq (value length)
+		 (regex-quoted (subseq source (1+ eindex)) nil))
+	     (cond ((listp value)
+		    (add-exp value))
+		   ((characterp value)
+		    (add-exp `((if (not (and (< index length)
+					     (eql (char string index) 
+						  ,value)))
+				   (return-from compare nil)
+				 (incf index)))))
+		   ((vectorp value)
+		    (add-exp `((let ((range ,value))
+				 (if (>= index length)
+				     (return-from compare nil))
+				 (if (= 1 (sbit range (char-code (char string index))))
+				     (incf index)
+				   (return-from compare nil)))))))
+	     (incf eindex length)))
+	  (t
+	   ;;
+	   ;; We have a literal character.  
+	   ;; Scan to see how many we have and if it is more than one
+	   ;; generate a string= verses as single eql.
+	   ;;
+	   (let* ((lit "")
+		  (term (dotimes (litindex (- (length source) eindex) nil)
+			  (let ((litchar (char source (+ eindex litindex))))
+			    (if (position litchar *regex-special-chars*)
+				(return litchar)
+			      (progn
+				(info "Now adding ~A index ~A to lit~%" litchar 
+				      litindex)
+				(setf lit (concatenate 'string lit 
+						       (string litchar)))))))))
+	     (if (= (length lit) 1)
+		 (add-exp `((if (not (and (< index length)
+					  (eql (char string index) ,current)))
+				(return-from compare nil)
+			      (incf index))))
+	       ;;
+	       ;; If we have a multi-character literal then we must
+	       ;; check to see if the next character (if there is one)
+	       ;; is an astrisk or a plus or a question mark.  If so then we must not use this
+	       ;; character in the big literal.
+	       (progn 
+		 (if (or (eql term #\*)
+                         (eql term #\+)
+                         (eql term #\?))
+		     (setf lit (subseq lit 0 (1- (length lit)))))
+		 (add-exp `((if (< length (+ index ,(length lit)))
+				(return-from compare nil))
+			    (if (not (string= string ,lit :start1 index
+					      :end1 (+ index ,(length lit))))
+				(return-from compare nil)
+			      (incf index ,(length lit)))))))
+	     (incf eindex (1- (length lit))))))))
+    ;;
+    ;; Plug end of list to return t.  If we made it this far then
+    ;; We have matched!
+    (add-exp '((setf (cadr (aref *regex-groups* 0))
+		     index)))
+    (add-exp '((return-from final-return t)))
+    ;;
+;;;    (print expression)
+    ;;
+    ;; Now take the expression list and turn it into a lambda expression
+    ;; replacing the special flags with lisp code.
+    ;; For example:  A BEGIN needs to be replace by an expression that
+    ;; saves the current index, then evaluates everything till it gets to
+    ;; the END then save the new index if it didn't fail.
+    ;; On an ASTRISK I need to take the previous expression and wrap
+    ;; it in a do that will evaluate the expression till an error
+    ;; occurs and then another do that encompases the remainder of the
+    ;; regular expression and iterates decrementing the index by one
+    ;; of the matched expression sizes and then returns nil.  After
+    ;; the last expression insert a form that does a return t so that
+    ;; if the entire nested sub-expression succeeds then the loop
+    ;; is broken manually.
+    ;; 
+    (setf result (copy-tree nil))
+    ;;
+    ;; Reversing the current expression makes building up the 
+    ;; lambda list easier due to the nexting of expressions when 
+    ;; and astrisk has been encountered.
+    (setf expression (reverse expression))
+    (do ((elt 0 (1+ elt)))
+	((>= elt (length expression)))
+      (let ((piece (nth elt expression)))
+	;;
+	;; Now check for PLUS, if so then ditto the expression and then let the
+	;; ASTRISK below handle the rest.
+	;;
+	(cond ((eql piece 'PLUS)
+	       (cond ((listp (nth (1+ elt) expression))
+		      (setf result (append (list (nth (1+ elt) expression))
+					   result)))
+		     ;;
+		     ;; duplicate the entire group
+		     ;; NOTE: This hasn't been implemented yet!!
+		     (t
+		      (error "GROUP repeat hasn't been implemented yet~%")))))
+	(cond ((listp piece)		;Just append the list
+	       (setf result (append (list piece) result)))
+	      ((eql piece 'QUESTION)	; Wrap it in a block that won't fail
+	       (cond ((listp (nth (1+ elt) expression))
+		      (setf result 
+			    (append `((progn (block compare
+						    ,(nth (1+ elt) 
+							  expression))
+					     t))
+				    result))
+		      (incf elt))
+		     ;;
+		     ;; This is a QUESTION on an entire group which
+		     ;; hasn't been implemented yet!!!
+		     ;;
+		     (t
+		      (error "Optional groups not implemented yet~%"))))
+	      ((or (eql piece 'ASTRISK) ; Do the wild thing!
+		   (eql piece 'PLUS))
+	       (cond ((listp (nth (1+ elt) expression))
+		      ;;
+		      ;; This is a single character wild card so
+		      ;; do the simple form.
+		      ;;
+		      (setf result 
+			    `((let ((oindex index))
+				(block compare
+				       (do ()
+					   (nil)
+					 ,(nth (1+ elt) expression)))
+				(do ((start index (1- start)))
+				    ((< start oindex) nil)
+				  (let ((index start))
+				    (block compare
+					   ,@result))))))
+		      (incf elt))
+		     (t
+		      ;;
+		      ;; This is a subgroup repeated so I must build
+		      ;; the loop using several values.
+		      ;;
+		      ))
+	       )
+	      (t t))))			; Just ignore everything else.
+    ;;
+    ;; Now wrap the result in a lambda list that can then be 
+    ;; invoked or compiled, however the user wishes.
+    ;;
+    (if anchored
+	(setf result
+	      `(lambda (string &key (start 0) (end (length string)))
+		 (setf *regex-groupings* ,group)
+		 (block final-return
+			(block compare
+			       (let ((index start)
+				     (length end))
+				 ,@result)))))
+      (setf result
+	    `(lambda (string &key (start 0) (end (length string)))
+	       (setf *regex-groupings* ,group)
+	       (block final-return
+		      (let ((length end))
+			,@fast-first
+			(do ((marker start (1+ marker)))
+			    ((> marker end) nil)
+			  (let ((index marker))
+			    (if (block compare
+				       ,@result)
+				(return t)))))))))))
+
+;; (provide 'nregex)

sources_non_forked/slimv/slime/packages.lisp

@@ -0,0 +1,202 @@
+(defpackage swank/backend
+  (:use cl)
+  (:nicknames swank-backend)
+  (:export *debug-swank-backend*
+           *log-output*
+           sldb-condition
+           compiler-condition
+           original-condition
+           message
+           source-context
+           condition
+           severity
+           with-compilation-hooks
+           make-location
+           location
+           location-p
+           location-buffer
+           location-position
+           location-hints
+           position-p
+           position-pos
+           print-output-to-string
+           quit-lisp
+           references
+           unbound-slot-filler
+           declaration-arglist
+           type-specifier-arglist
+           with-struct
+           when-let
+           defimplementation
+           converting-errors-to-error-location
+           make-error-location
+           deinit-log-output
+           ;; interrupt macro for the backend
+           *pending-slime-interrupts*
+           check-slime-interrupts
+           *interrupt-queued-handler*
+           ;; inspector related symbols
+           emacs-inspect
+           label-value-line
+           label-value-line*
+           boolean-to-feature-expression
+           with-symbol
+           choose-symbol
+           ;; package helper for backend
+           import-to-swank-mop
+           import-swank-mop-symbols
+           ;;
+           default-directory
+           set-default-directory
+           frame-source-location
+           restart-frame
+           gdb-initial-commands
+           sldb-break-on-return
+           buffer-first-change
+
+           profiled-functions
+           unprofile-all
+           profile-report
+           profile-reset
+           profile-package
+
+           with-collected-macro-forms
+           auto-flush-loop
+           *auto-flush-interval*))
+
+(defpackage swank/rpc
+  (:use :cl)
+  (:export
+   read-message
+   read-packet
+   swank-reader-error
+   swank-reader-error.packet
+   swank-reader-error.cause
+   write-message))
+
+(defpackage swank/match
+  (:use cl)
+  (:export match))
+
+;; FIXME: rename to sawnk/mop
+(defpackage swank-mop
+  (:use)
+  (:export
+   ;; classes
+   standard-generic-function
+   standard-slot-definition
+   standard-method
+   standard-class
+   eql-specializer
+   eql-specializer-object
+   ;; standard-class readers
+   class-default-initargs
+   class-direct-default-initargs
+   class-direct-slots
+   class-direct-subclasses
+   class-direct-superclasses
+   class-finalized-p
+   class-name
+   class-precedence-list
+   class-prototype
+   class-slots
+   specializer-direct-methods
+   ;; generic function readers
+   generic-function-argument-precedence-order
+   generic-function-declarations
+   generic-function-lambda-list
+   generic-function-methods
+   generic-function-method-class
+   generic-function-method-combination
+   generic-function-name
+   ;; method readers
+   method-generic-function
+   method-function
+   method-lambda-list
+   method-specializers
+   method-qualifiers
+   ;; slot readers
+   slot-definition-allocation
+   slot-definition-documentation
+   slot-definition-initargs
+   slot-definition-initform
+   slot-definition-initfunction
+   slot-definition-name
+   slot-definition-type
+   slot-definition-readers
+   slot-definition-writers
+   slot-boundp-using-class
+   slot-value-using-class
+   slot-makunbound-using-class
+   ;; generic function protocol
+   compute-applicable-methods-using-classes
+   finalize-inheritance))
+
+(defpackage swank
+  (:use cl swank/backend swank/match swank/rpc)
+  (:export #:startup-multiprocessing
+           #:start-server
+           #:create-server
+           #:stop-server
+           #:restart-server
+           #:ed-in-emacs
+           #:inspect-in-emacs
+           #:print-indentation-lossage
+           #:invoke-slime-debugger
+           #:swank-debugger-hook
+           #:emacs-inspect
+           ;;#:inspect-slot-for-emacs
+           ;; These are user-configurable variables:
+           #:*communication-style*
+           #:*dont-close*
+           #:*fasl-pathname-function*
+           #:*log-events*
+           #:*use-dedicated-output-stream*
+           #:*dedicated-output-stream-port*
+           #:*configure-emacs-indentation*
+           #:*readtable-alist*
+           #:*globally-redirect-io*
+           #:*global-debugger*
+           #:*sldb-quit-restart*
+           #:*backtrace-printer-bindings*
+           #:*default-worker-thread-bindings*
+           #:*macroexpand-printer-bindings*
+           #:*swank-pprint-bindings*
+           #:*record-repl-results*
+           #:*inspector-verbose*
+           ;; This is SETFable.
+           #:debug-on-swank-error
+           ;; These are re-exported directly from the backend:
+           #:buffer-first-change
+           #:frame-source-location
+           #:gdb-initial-commands
+           #:restart-frame
+           #:sldb-step
+           #:sldb-break
+           #:sldb-break-on-return
+           #:profiled-functions
+           #:profile-report
+           #:profile-reset
+           #:unprofile-all
+           #:profile-package
+           #:default-directory
+           #:set-default-directory
+           #:quit-lisp
+           #:eval-for-emacs
+           #:eval-in-emacs
+           #:ed-rpc
+           #:ed-rpc-no-wait
+           #:y-or-n-p-in-emacs
+           #:*find-definitions-right-trim*
+           #:*find-definitions-left-trim*
+           #:*after-toggle-trace-hook*
+           #:unreadable-result
+           #:unreadable-result-p
+           #:unreadable-result-string
+           #:parse-string
+           #:from-string
+           #:to-string
+           #:*swank-debugger-condition*
+           #:run-hook-with-args-until-success
+           #:make-output-function-for-target
+           #:make-output-stream-for-target))

sources_non_forked/slimv/slime/sbcl-pprint-patch.lisp

@@ -0,0 +1,332 @@
+;; Pretty printer patch for SBCL, which adds the "annotations" feature
+;; required for sending presentations through pretty-printing streams.
+;;
+;; The section marked "Changed functions" and the DEFSTRUCT
+;; PRETTY-STREAM are based on SBCL's pprint.lisp.
+;; 
+;; Public domain.
+
+(in-package "SB!PRETTY")
+
+(defstruct (annotation (:include queued-op))
+  (handler (constantly nil) :type function)
+  (record))
+
+
+(defstruct (pretty-stream (:include sb!kernel:ansi-stream
+				    (out #'pretty-out)
+				    (sout #'pretty-sout)
+				    (misc #'pretty-misc))
+			  (:constructor make-pretty-stream (target))
+			  (:copier nil))
+  ;; Where the output is going to finally go.
+  (target (missing-arg) :type stream)
+  ;; Line length we should format to. Cached here so we don't have to keep
+  ;; extracting it from the target stream.
+  (line-length (or *print-right-margin*
+		   (sb!impl::line-length target)
+		   default-line-length)
+	       :type column)
+  ;; A simple string holding all the text that has been output but not yet
+  ;; printed.
+  (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
+  ;; The index into BUFFER where more text should be put.
+  (buffer-fill-pointer 0 :type index)
+  ;; Whenever we output stuff from the buffer, we shift the remaining noise
+  ;; over. This makes it difficult to keep references to locations in
+  ;; the buffer. Therefore, we have to keep track of the total amount of
+  ;; stuff that has been shifted out of the buffer.
+  (buffer-offset 0 :type posn)
+  ;; The column the first character in the buffer will appear in. Normally
+  ;; zero, but if we end up with a very long line with no breaks in it we
+  ;; might have to output part of it. Then this will no longer be zero.
+  (buffer-start-column (or (sb!impl::charpos target) 0) :type column)
+  ;; The line number we are currently on. Used for *PRINT-LINES*
+  ;; abbreviations and to tell when sections have been split across
+  ;; multiple lines.
+  (line-number 0 :type index)
+  ;; the value of *PRINT-LINES* captured at object creation time. We
+  ;; use this, instead of the dynamic *PRINT-LINES*, to avoid
+  ;; weirdness like
+  ;;   (let ((*print-lines* 50))
+  ;;     (pprint-logical-block ..
+  ;;       (dotimes (i 10)
+  ;;         (let ((*print-lines* 8))
+  ;;           (print (aref possiblybigthings i) prettystream)))))
+  ;; terminating the output of the entire logical blockafter 8 lines.
+  (print-lines *print-lines* :type (or index null) :read-only t)
+  ;; Stack of logical blocks in effect at the buffer start.
+  (blocks (list (make-logical-block)) :type list)
+  ;; Buffer holding the per-line prefix active at the buffer start.
+  ;; Indentation is included in this. The length of this is stored
+  ;; in the logical block stack.
+  (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
+  ;; Buffer holding the total remaining suffix active at the buffer start.
+  ;; The characters are right-justified in the buffer to make it easier
+  ;; to output the buffer. The length is stored in the logical block
+  ;; stack.
+  (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
+  ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
+  ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
+  ;; cons. Adding things to the queue is basically (setf (cdr head) (list
+  ;; new)) and removing them is basically (pop tail) [except that care must
+  ;; be taken to handle the empty queue case correctly.]
+  (queue-tail nil :type list)
+  (queue-head nil :type list)
+  ;; Block-start queue entries in effect at the queue head.
+  (pending-blocks nil :type list)
+  ;; Queue of annotations to the buffer
+  (annotations-tail nil :type list)
+  (annotations-head nil :type list))
+
+
+(defmacro enqueue (stream type &rest args)
+  (let ((constructor (intern (concatenate 'string
+					  "MAKE-"
+					  (symbol-name type))
+			     "SB-PRETTY")))
+    (once-only ((stream stream)
+		(entry `(,constructor :posn
+				      (index-posn
+				       (pretty-stream-buffer-fill-pointer
+					,stream)
+				       ,stream)
+				      ,@args))
+		(op `(list ,entry))
+		(head `(pretty-stream-queue-head ,stream)))
+      `(progn
+	 (if ,head
+	     (setf (cdr ,head) ,op)
+	     (setf (pretty-stream-queue-tail ,stream) ,op))
+	 (setf (pretty-stream-queue-head ,stream) ,op)
+	 ,entry))))
+
+;;;
+;;; New helper functions
+;;;
+
+(defun enqueue-annotation (stream handler record)
+  (enqueue stream annotation :handler handler
+	   :record record))
+
+(defun re-enqueue-annotation (stream annotation)
+  (let* ((annotation-cons (list annotation))
+	 (head (pretty-stream-annotations-head stream)))
+    (if head
+	(setf (cdr head) annotation-cons)
+	(setf (pretty-stream-annotations-tail stream) annotation-cons))
+    (setf (pretty-stream-annotations-head stream) annotation-cons)
+    nil))
+
+(defun re-enqueue-annotations (stream end)
+  (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail)
+     while (and tail (not (eql (car tail) end)))
+     when (annotation-p (car tail)) 
+     do (re-enqueue-annotation stream (car tail))))
+
+(defun dequeue-annotation (stream &key end-posn)
+  (let ((next-annotation (car (pretty-stream-annotations-tail stream))))
+    (when next-annotation
+      (when (or (not end-posn)
+		(<= (annotation-posn next-annotation) end-posn))
+	(pop (pretty-stream-annotations-tail stream))
+	(unless (pretty-stream-annotations-tail stream)
+	  (setf (pretty-stream-annotations-head stream) nil))
+	next-annotation))))
+
+(defun invoke-annotation (stream annotation truncatep)
+  (let ((target (pretty-stream-target stream)))
+    (funcall (annotation-handler annotation)
+	     (annotation-record annotation)
+	     target
+	     truncatep)))
+
+(defun output-buffer-with-annotations (stream end)
+  (let ((target (pretty-stream-target stream))
+	(buffer (pretty-stream-buffer stream))
+	(end-posn (index-posn end stream))
+	(start 0))
+    (loop
+       for annotation = (dequeue-annotation stream :end-posn end-posn)
+       while annotation
+       do
+	 (let ((annotation-index (posn-index (annotation-posn annotation)
+					     stream)))
+	   (when (> annotation-index start)
+	     (write-string buffer target :start start 
+			   :end annotation-index)
+	     (setf start annotation-index))
+	   (invoke-annotation stream annotation nil)))
+    (when (> end start)
+      (write-string buffer target :start start :end end))))
+
+(defun flush-annotations (stream end truncatep)
+  (let ((end-posn (index-posn end stream)))
+    (loop
+       for annotation = (dequeue-annotation stream :end-posn end-posn)
+       while annotation
+       do (invoke-annotation stream annotation truncatep))))
+
+;;;
+;;; Changed functions
+;;;
+
+(defun maybe-output (stream force-newlines-p)
+  (declare (type pretty-stream stream))
+  (let ((tail (pretty-stream-queue-tail stream))
+	(output-anything nil))
+    (loop
+      (unless tail
+	(setf (pretty-stream-queue-head stream) nil)
+	(return))
+      (let ((next (pop tail)))
+	(etypecase next
+	  (newline
+	   (when (ecase (newline-kind next)
+		   ((:literal :mandatory :linear) t)
+		   (:miser (misering-p stream))
+		   (:fill
+		    (or (misering-p stream)
+			(> (pretty-stream-line-number stream)
+			   (logical-block-section-start-line
+			    (first (pretty-stream-blocks stream))))
+			(ecase (fits-on-line-p stream
+					       (newline-section-end next)
+					       force-newlines-p)
+			  ((t) nil)
+			  ((nil) t)
+			  (:dont-know
+			   (return))))))
+	     (setf output-anything t)
+	     (output-line stream next)))
+	  (indentation
+	   (unless (misering-p stream)
+	     (set-indentation stream
+			      (+ (ecase (indentation-kind next)
+				   (:block
+				    (logical-block-start-column
+				     (car (pretty-stream-blocks stream))))
+				   (:current
+				    (posn-column
+				     (indentation-posn next)
+				     stream)))
+				 (indentation-amount next)))))
+	  (block-start
+	   (ecase (fits-on-line-p stream (block-start-section-end next)
+				  force-newlines-p)
+	     ((t)
+	      ;; Just nuke the whole logical block and make it look like one
+	      ;; nice long literal.  (But don't nuke annotations.)
+	      (let ((end (block-start-block-end next)))
+		(expand-tabs stream end)
+		(re-enqueue-annotations stream end)
+		(setf tail (cdr (member end tail)))))
+	     ((nil)
+	      (really-start-logical-block
+	       stream
+	       (posn-column (block-start-posn next) stream)
+	       (block-start-prefix next)
+	       (block-start-suffix next)))
+	     (:dont-know
+	      (return))))
+	  (block-end
+	   (really-end-logical-block stream))
+	  (tab
+	   (expand-tabs stream next))
+	  (annotation
+	   (re-enqueue-annotation stream next))))
+      (setf (pretty-stream-queue-tail stream) tail))
+    output-anything))
+
+(defun output-line (stream until)
+  (declare (type pretty-stream stream)
+	   (type newline until))
+  (let* ((target (pretty-stream-target stream))
+	 (buffer (pretty-stream-buffer stream))
+	 (kind (newline-kind until))
+	 (literal-p (eq kind :literal))
+	 (amount-to-consume (posn-index (newline-posn until) stream))
+	 (amount-to-print
+	  (if literal-p
+	      amount-to-consume
+	      (let ((last-non-blank
+		     (position #\space buffer :end amount-to-consume
+			       :from-end t :test #'char/=)))
+		(if last-non-blank
+		    (1+ last-non-blank)
+		    0)))))
+    (output-buffer-with-annotations stream amount-to-print)
+    (flush-annotations stream amount-to-consume nil)
+    (let ((line-number (pretty-stream-line-number stream)))
+      (incf line-number)
+      (when (and (not *print-readably*)
+		 (pretty-stream-print-lines stream)
+		 (>= line-number (pretty-stream-print-lines stream)))
+	(write-string " .." target)
+	(flush-annotations stream 
+			   (pretty-stream-buffer-fill-pointer stream)
+			   t)
+	(let ((suffix-length (logical-block-suffix-length
+			      (car (pretty-stream-blocks stream)))))
+	  (unless (zerop suffix-length)
+	    (let* ((suffix (pretty-stream-suffix stream))
+		   (len (length suffix)))
+	      (write-string suffix target
+			    :start (- len suffix-length)
+			    :end len))))
+	(throw 'line-limit-abbreviation-happened t))
+      (setf (pretty-stream-line-number stream) line-number)
+      (write-char #\newline target)
+      (setf (pretty-stream-buffer-start-column stream) 0)
+      (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+	     (block (first (pretty-stream-blocks stream)))
+	     (prefix-len
+	      (if literal-p
+		  (logical-block-per-line-prefix-end block)
+		  (logical-block-prefix-length block)))
+	     (shift (- amount-to-consume prefix-len))
+	     (new-fill-ptr (- fill-ptr shift))
+	     (new-buffer buffer)
+	     (buffer-length (length buffer)))
+	(when (> new-fill-ptr buffer-length)
+	  (setf new-buffer
+		(make-string (max (* buffer-length 2)
+				  (+ buffer-length
+				     (floor (* (- new-fill-ptr buffer-length)
+					       5)
+					    4)))))
+	  (setf (pretty-stream-buffer stream) new-buffer))
+	(replace new-buffer buffer
+		 :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
+	(replace new-buffer (pretty-stream-prefix stream)
+		 :end1 prefix-len)
+	(setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+	(incf (pretty-stream-buffer-offset stream) shift)
+	(unless literal-p
+	  (setf (logical-block-section-column block) prefix-len)
+	  (setf (logical-block-section-start-line block) line-number))))))
+
+(defun output-partial-line (stream)
+  (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+	 (tail (pretty-stream-queue-tail stream))
+	 (count
+	  (if tail
+	      (posn-index (queued-op-posn (car tail)) stream)
+	      fill-ptr))
+	 (new-fill-ptr (- fill-ptr count))
+	 (buffer (pretty-stream-buffer stream)))
+    (when (zerop count)
+      (error "Output-partial-line called when nothing can be output."))
+    (output-buffer-with-annotations stream count)
+    (incf (pretty-stream-buffer-start-column stream) count)
+    (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
+    (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+    (incf (pretty-stream-buffer-offset stream) count)))
+
+(defun force-pretty-output (stream)
+  (maybe-output stream nil)
+  (expand-tabs stream nil)
+  (re-enqueue-annotations stream nil)
+  (output-buffer-with-annotations stream 
+				  (pretty-stream-buffer-fill-pointer stream)))
+	      

sources_non_forked/slimv/slime/start-swank.lisp

@@ -0,0 +1,40 @@
+;;; This file is intended to be loaded by an implementation to
+;;; get a running swank server
+;;; e.g. sbcl --load start-swank.lisp
+;;;
+;;; Default port is 4005
+
+;;; For additional swank-side configurations see
+;;; 6.2 section of the Slime user manual.
+;;;
+;;; Modified for Slimv:
+;;; - don't close connection
+;;; - pass swank port in environment variable
+
+(load (merge-pathnames "swank-loader.lisp" *load-truename*))
+
+(swank-loader:init
+ :delete nil         ; delete any existing SWANK packages
+ :reload nil         ; reload SWANK, even if the SWANK package already exists
+ :load-contribs nil  ; load all contribs
+ :from-emacs nil)    ; not started from emacs
+
+(defun my-getenv (name &optional default)
+  #+CMU
+  (let ((x (assoc name ext:*environment-list*
+                  :test #'string=)))
+    (if x (cdr x) default))
+  #-CMU
+  (or
+    #+Allegro (sys:getenv name)
+    #+CLISP (ext:getenv name)
+    #+ECL (si:getenv name)
+    #+SBCL (sb-unix::posix-getenv name)
+    #+LISPWORKS (lispworks:environment-variable name)
+    #+CCL (ccl::getenv name)
+    default))
+
+(swank:create-server :port (parse-integer (my-getenv "SWANK_PORT" "4005"))
+                     ;; if non-nil the connection won't be closed
+                     ;; after connecting
+                     :dont-close t)

sources_non_forked/slimv/slime/swank-loader.lisp

@@ -0,0 +1,376 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-loader.lisp --- Compile and load the Slime backend.
+;;;
+;;; Created 2003, James Bielman <jamesjb@jamesjb.com>
+;;;
+;;; This code has been placed in the Public Domain.  All warranties
+;;; are disclaimed.
+;;;
+
+;; If you want customize the source- or fasl-directory you can set
+;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
+;; before loading this files.
+;; E.g.:
+;;
+;;   (load ".../swank-loader.lisp")
+;;   (setq swank-loader::*fasl-directory* "/tmp/fasl/")
+;;   (swank-loader:init)
+
+(cl:defpackage :swank-loader
+  (:use :cl)
+  (:export :init
+           :dump-image
+           :list-fasls
+           :*source-directory*
+           :*fasl-directory*
+           :*started-from-emacs*))
+
+(cl:in-package :swank-loader)
+
+(defvar *started-from-emacs* nil)
+
+(defvar *source-directory*
+  (make-pathname :name nil :type nil
+                 :defaults (or *load-pathname* *default-pathname-defaults*))
+  "The directory where to look for the source.")
+
+(defparameter *sysdep-files*
+  #+cmu '((swank source-path-parser) (swank source-file-cache) (swank cmucl)
+          (swank gray))
+  #+scl '((swank source-path-parser) (swank source-file-cache) (swank scl)
+          (swank gray))
+  #+sbcl '((swank source-path-parser) (swank source-file-cache) (swank sbcl)
+           (swank gray))
+  #+clozure '(metering (swank ccl) (swank gray))
+  #+lispworks '((swank lispworks) (swank gray))
+  #+allegro '((swank allegro) (swank gray))
+  #+clisp '(xref metering (swank clisp) (swank gray))
+  #+armedbear '((swank abcl))
+  #+cormanlisp '((swank corman) (swank gray))
+  #+ecl '((swank ecl) (swank gray))
+  #+clasp '(metering (swank clasp) (swank gray))
+  #+mkcl '((swank mkcl) (swank gray))
+  #+mezzano '((swank mezzano) (swank gray))
+  )
+
+(defparameter *implementation-features*
+  '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp
+    :armedbear :gcl :ecl :scl :mkcl :clasp :mezzano))
+
+(defparameter *os-features*
+  '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
+    :unix :mezzano))
+
+(defparameter *architecture-features*
+  '(:powerpc :ppc :ppc64 :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
+    :sparc64 :sparc :hppa64 :hppa :arm :armv5l :armv6l :armv7l :arm64 :aarch64
+    :pentium3 :pentium4
+    :mips :mipsel
+    :java-1.4 :java-1.5 :java-1.6 :java-1.7))
+
+(defun q (s) (read-from-string s))
+
+#+ecl
+(defun ecl-version-string ()
+  (format nil "~A~@[-~A~]"
+          (lisp-implementation-version)
+          (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)
+            (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id"))))
+              (when (>= (length vcs-id) 8)
+                (subseq vcs-id 0 8))))))
+
+#+clasp
+(defun clasp-version-string ()
+  (format nil "~A~@[-~A~]"
+          (lisp-implementation-version)
+          (core:lisp-implementation-id)))
+
+(defun lisp-version-string ()
+  #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
+                                    (lisp-implementation-version))
+  #+(or cormanlisp scl mkcl) (lisp-implementation-version)
+  #+sbcl (format nil "~a~:[~;-no-threads~]"
+                 (lisp-implementation-version)
+                 #+sb-thread nil
+                 #-sb-thread t)
+  #+lispworks (lisp-implementation-version)
+  #+allegro   (format nil "~@{~a~}"
+                      excl::*common-lisp-version-number*
+                      (if (string= 'lisp "LISP") "A" "M")     ; ANSI vs MoDeRn
+                      (if (member :smp *features*) "s" "")
+                      (if (member :64bit *features*) "-64bit" "")
+                      (excl:ics-target-case
+                       (:-ics "")
+                       (:+ics "-ics")))
+  #+clisp     (let ((s (lisp-implementation-version)))
+                (subseq s 0 (position #\space s)))
+  #+armedbear (lisp-implementation-version)
+  #+ecl (ecl-version-string)
+  #+clasp (clasp-version-string)
+  #+mezzano (let ((s (lisp-implementation-version)))
+              (subseq s 0 (position #\space s))))
+
+(defun unique-dir-name ()
+  "Return a name that can be used as a directory name that is
+unique to a Lisp implementation, Lisp implementation version,
+operating system, and hardware architecture."
+  (flet ((first-of (features)
+           (loop for f in features
+                 when (find f *features*) return it))
+         (maybe-warn (value fstring &rest args)
+           (cond (value)
+                 (t (apply #'warn fstring args)
+                    "unknown"))))
+    (let ((lisp (maybe-warn (first-of *implementation-features*)
+                            "No implementation feature found in ~a."
+                            *implementation-features*))
+          (os   (maybe-warn (first-of *os-features*)
+                            "No os feature found in ~a." *os-features*))
+          (arch (maybe-warn (first-of *architecture-features*)
+                            "No architecture feature found in ~a."
+                            *architecture-features*))
+          (version (maybe-warn (lisp-version-string)
+                               "Don't know how to get Lisp ~
+                                implementation version.")))
+      (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
+
+(defun file-newer-p (new-file old-file)
+  "Returns true if NEW-FILE is newer than OLD-FILE."
+  (> (file-write-date new-file) (file-write-date old-file)))
+
+(defun string-starts-with (string prefix)
+  (string-equal string prefix :end1 (min (length string) (length prefix))))
+
+(defun slime-version-string ()
+  "Return a string identifying the SLIME version.
+Return nil if nothing appropriate is available."
+  (with-open-file (s (merge-pathnames "slime.el" *source-directory*)
+                     :if-does-not-exist nil)
+    (when s
+      (loop with prefix = ";; Version: "
+            for line = (read-line s nil :eof)
+            until (eq line :eof)
+            when (string-starts-with line prefix)
+              return (subseq line (length prefix))))))
+
+(defun default-fasl-dir ()
+  (merge-pathnames
+   (make-pathname
+    :directory `(:relative ".slime" "fasl"
+                 ,@(if (slime-version-string) (list (slime-version-string)))
+                 ,(unique-dir-name)))
+   (user-homedir-pathname)))
+
+(defvar *fasl-directory* (default-fasl-dir)
+  "The directory where fasl files should be placed.")
+
+(defun binary-pathname (src-pathname binary-dir)
+  "Return the pathname where SRC-PATHNAME's binary should be compiled."
+  (let ((cfp (compile-file-pathname src-pathname)))
+    (merge-pathnames (make-pathname :name (pathname-name cfp)
+                                    :type (pathname-type cfp))
+                     binary-dir)))
+
+(defun handle-swank-load-error (condition context pathname)
+  (fresh-line *error-output*)
+  (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
+    (format *error-output*
+            "~%Error ~A ~A:~%  ~A~%"
+            context pathname condition)))
+
+(defun compile-files (files fasl-dir load quiet)
+  "Compile each file in FILES if the source is newer than its
+corresponding binary, or the file preceding it was recompiled.
+If LOAD is true, load the fasl file."
+  (let ((needs-recompile nil)
+        (state :unknown))
+    (dolist (src files)
+      (let ((dest (binary-pathname src fasl-dir)))
+        (handler-bind
+            ((error (lambda (c)
+                      (ecase state
+                        (:compile (handle-swank-load-error c "compiling" src))
+                        (:load    (handle-swank-load-error c "loading" dest))
+                        (:unknown (handle-swank-load-error c "???ing" src))))))
+          (when (or needs-recompile
+                    (not (probe-file dest))
+                    (file-newer-p src dest))
+            (ensure-directories-exist dest)
+            ;; need to recompile SRC, so we'll need to recompile
+            ;; everything after this too.
+            (setf needs-recompile t
+                  state :compile)
+            (or (compile-file src :output-file dest :print nil
+                                  :verbose (not quiet))
+                ;; An implementation may not necessarily signal a
+                ;; condition itself when COMPILE-FILE fails (e.g. ECL)
+                (error "COMPILE-FILE returned NIL.")))
+          (when load
+            (setf state :load)
+            (load dest :verbose (not quiet))))))))
+
+#+cormanlisp
+(defun compile-files (files fasl-dir load quiet)
+  "Corman Lisp has trouble with compiled files."
+  (declare (ignore fasl-dir))
+  (when load
+    (dolist (file files)
+      (load file :verbose (not quiet)
+      (force-output)))))
+
+(defun load-user-init-file ()
+  "Load the user init file, return NIL if it does not exist."
+  (load (merge-pathnames (user-homedir-pathname)
+                         (make-pathname :name ".swank" :type "lisp"))
+        :if-does-not-exist nil))
+
+(defun load-site-init-file (dir)
+  (load (make-pathname :name "site-init" :type "lisp"
+                       :defaults dir)
+        :if-does-not-exist nil))
+
+(defun src-files (names src-dir)
+  (mapcar (lambda (name)
+            (multiple-value-bind (dirs name)
+                (etypecase name
+                  (symbol (values '() name))
+                  (cons (values (butlast name) (car (last name)))))
+              (make-pathname
+               :directory (append (or (pathname-directory src-dir)
+                                      '(:relative))
+                                  (mapcar #'string-downcase dirs))
+               :name (string-downcase name)
+               :type "lisp"
+               :defaults src-dir)))
+          names))
+
+(defvar *swank-files*
+  `(packages
+    (swank backend) ,@*sysdep-files* (swank match) (swank rpc)
+    swank))
+
+(defvar *contribs*
+  '(swank-util swank-repl
+    swank-c-p-c swank-arglists swank-fuzzy
+    swank-fancy-inspector
+    swank-presentations swank-presentation-streams
+    #+(or asdf2 asdf3 sbcl ecl) swank-asdf
+    swank-package-fu
+    swank-hyperdoc
+    #+sbcl swank-sbcl-exts
+    swank-mrepl
+    swank-trace-dialog
+    swank-macrostep
+    swank-quicklisp)
+  "List of names for contrib modules.")
+
+(defun append-dir (absolute name)
+  (merge-pathnames
+   (make-pathname :directory `(:relative ,name) :defaults absolute)
+   absolute))
+
+(defun contrib-dir (base-dir)
+  (append-dir base-dir "contrib"))
+
+(defun load-swank (&key (src-dir *source-directory*)
+                     (fasl-dir *fasl-directory*)
+                        quiet)
+  (with-compilation-unit ()
+    (compile-files (src-files *swank-files* src-dir) fasl-dir t quiet))
+  (funcall (q "swank::before-init")
+           (slime-version-string)
+           (list (contrib-dir fasl-dir)
+                 (contrib-dir src-dir))))
+
+(defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir)
+  (let ((newest (reduce #'max (mapcar #'file-write-date swank-files))))
+    (dolist (src contrib-files)
+      (let ((fasl (binary-pathname src fasl-dir)))
+        (when (and (probe-file fasl)
+                   (<= (file-write-date fasl) newest))
+          (delete-file fasl))))))
+
+(defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
+                           (fasl-dir (contrib-dir *fasl-directory*))
+                           (swank-src-dir *source-directory*)
+                           load quiet)
+  (let* ((swank-src-files (src-files *swank-files* swank-src-dir))
+         (contrib-src-files (src-files *contribs* src-dir)))
+    (delete-stale-contrib-fasl-files swank-src-files contrib-src-files
+                                     fasl-dir)
+    (compile-files contrib-src-files fasl-dir load quiet)))
+
+(defun loadup ()
+  (load-swank)
+  (compile-contribs :load t))
+
+(defun setup ()
+  (load-site-init-file *source-directory*)
+  (load-user-init-file)
+  (when (#-clisp probe-file
+         #+clisp ext:probe-directory
+         (contrib-dir *source-directory*))
+    (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))))
+  (funcall (q "swank::init")))
+
+(defun list-swank-packages ()
+  (remove-if-not (lambda (package)
+                   (let ((name (package-name package)))
+                     (and (string-not-equal name "swank-loader")
+                          (string-starts-with name "swank"))))
+                 (list-all-packages)))
+
+(defun delete-packages (packages)
+  (dolist (package packages)
+    (flet ((handle-package-error (c)
+             (let ((pkgs (set-difference (package-used-by-list package)
+                                         packages)))
+               (when pkgs
+                 (warn "deleting ~a which is used by ~{~a~^, ~}."
+                       package pkgs))
+               (continue c))))
+      (handler-bind ((package-error #'handle-package-error))
+        (delete-package package)))))
+
+(defun init (&key delete reload load-contribs (setup t)
+                  (quiet (not *load-verbose*))
+                  from-emacs)
+  "Load SWANK and initialize some global variables.
+If DELETE is true, delete any existing SWANK packages.
+If RELOAD is true, reload SWANK, even if the SWANK package already exists.
+If LOAD-CONTRIBS is true, load all contribs
+If SETUP is true, load user init files and initialize some
+global variabes in SWANK."
+  (when from-emacs
+    (setf *started-from-emacs* t))
+  (when (and delete (find-package :swank))
+    (delete-packages (list-swank-packages)))
+  (cond ((or (not (find-package :swank)) reload)
+         (load-swank :quiet quiet))
+        (t
+         (warn "Not reloading SWANK.  Package already exists.")))
+  (when load-contribs
+    (compile-contribs :load t :quiet quiet))
+  (when setup
+    (setup)))
+
+(defun dump-image (filename)
+  (init :setup nil)
+  (funcall (q "swank/backend:save-image") filename))
+
+(defun list-fasls (&key (include-contribs t) (compile t)
+                        (quiet (not *compile-verbose*)))
+  "List up SWANK's fasls along with their dependencies."
+  (flet ((collect-fasls (files fasl-dir)
+           (when compile
+             (compile-files files fasl-dir nil quiet))
+           (loop for src in files
+                 when (probe-file (binary-pathname src fasl-dir))
+                   collect it)))
+    (append (collect-fasls (src-files *swank-files* *source-directory*)
+                           *fasl-directory*)
+            (when include-contribs
+              (collect-fasls (src-files *contribs*
+                                        (contrib-dir *source-directory*))
+                             (contrib-dir *fasl-directory*))))))

sources_non_forked/slimv/slime/swank.asd

@@ -0,0 +1,36 @@
+;;; -*- lisp -*-
+
+;; ASDF system definition for loading the Swank server independently
+;; of Emacs.
+;;
+;; This is only useful if you want to start a Swank server in a Lisp
+;; processes that doesn't run under Emacs. Lisp processes created by
+;; `M-x slime' automatically start the server.
+
+;; Usage:
+;;
+;;   (require :swank)
+;;   (swank:create-swank-server PORT) => ACTUAL-PORT
+;;
+;; (PORT can be zero to mean "any available port".)
+;; Then the Swank server is running on localhost:ACTUAL-PORT. You can
+;; use `M-x slime-connect' to connect Emacs to it.
+;;
+;; This code has been placed in the Public Domain.  All warranties
+;; are disclaimed.
+
+(defclass swank-loader-file (asdf:cl-source-file) ())
+
+;;;; after loading run init
+
+(defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file))
+  ;; swank-loader computes its own source/fasl relation based on the
+  ;; TRUENAME of the loader file, so we need a "manual" CL:LOAD
+  ;; invocation here.
+  (load (asdf::component-pathname f))
+  ;; After loading, run the swank-loader init routines.
+  (funcall (read-from-string "swank-loader::init") :reload t))
+
+(asdf:defsystem :swank
+  :default-component-class swank-loader-file
+  :components ((:file "swank-loader")))

sources_non_forked/slimv/slime/swank/ccl.lisp

@@ -0,0 +1,868 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-ccl.lisp --- SLIME backend for Clozure CL.
+;;;
+;;; Copyright (C) 2003, James Bielman  <jamesjb@jamesjb.com>
+;;;
+;;; This program is licensed under the terms of the Lisp Lesser GNU
+;;; Public License, known as the LLGPL, and distributed with Clozure CL
+;;; as the file "LICENSE".  The LLGPL consists of a preamble and the
+;;; LGPL, which is distributed with Clozure CL as the file "LGPL".  Where
+;;; these conflict, the preamble takes precedence.
+;;;
+;;; The LLGPL is also available online at
+;;; http://opensource.franz.com/preamble.html
+
+(defpackage swank/ccl
+  (:use cl swank/backend))
+
+(in-package swank/ccl)
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+  (assert (and (= ccl::*openmcl-major-version* 1)
+               (>= ccl::*openmcl-minor-version* 4))
+          () "This file needs CCL version 1.4 or newer"))
+
+(defimplementation gray-package-name ()
+  "CCL")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (multiple-value-bind (ok err) (ignore-errors (require 'xref))
+    (unless ok
+      (warn "~a~%" err))))
+
+;;; swank-mop
+
+(import-to-swank-mop
+ '( ;; classes
+   cl:standard-generic-function
+   ccl:standard-slot-definition
+   cl:method
+   cl:standard-class
+   ccl:eql-specializer
+   openmcl-mop:finalize-inheritance
+   openmcl-mop:compute-applicable-methods-using-classes
+   ;; standard-class readers
+   openmcl-mop:class-default-initargs
+   openmcl-mop:class-direct-default-initargs
+   openmcl-mop:class-direct-slots
+   openmcl-mop:class-direct-subclasses
+   openmcl-mop:class-direct-superclasses
+   openmcl-mop:class-finalized-p
+   cl:class-name
+   openmcl-mop:class-precedence-list
+   openmcl-mop:class-prototype
+   openmcl-mop:class-slots
+   openmcl-mop:specializer-direct-methods
+   ;; eql-specializer accessors
+   openmcl-mop:eql-specializer-object
+   ;; generic function readers
+   openmcl-mop:generic-function-argument-precedence-order
+   openmcl-mop:generic-function-declarations
+   openmcl-mop:generic-function-lambda-list
+   openmcl-mop:generic-function-methods
+   openmcl-mop:generic-function-method-class
+   openmcl-mop:generic-function-method-combination
+   openmcl-mop:generic-function-name
+   ;; method readers
+   openmcl-mop:method-generic-function
+   openmcl-mop:method-function
+   openmcl-mop:method-lambda-list
+   openmcl-mop:method-specializers
+   openmcl-mop:method-qualifiers
+   ;; slot readers
+   openmcl-mop:slot-definition-allocation
+   openmcl-mop:slot-definition-documentation
+   openmcl-mop:slot-value-using-class
+   openmcl-mop:slot-definition-initargs
+   openmcl-mop:slot-definition-initform
+   openmcl-mop:slot-definition-initfunction
+   openmcl-mop:slot-definition-name
+   openmcl-mop:slot-definition-type
+   openmcl-mop:slot-definition-readers
+   openmcl-mop:slot-definition-writers
+   openmcl-mop:slot-boundp-using-class
+   openmcl-mop:slot-makunbound-using-class))
+
+;;; UTF8
+
+(defimplementation string-to-utf8 (string)
+  (ccl:encode-string-to-octets string :external-format :utf-8))
+
+(defimplementation utf8-to-string (octets)
+  (ccl:decode-string-from-octets octets :external-format :utf-8))
+
+;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+  :spawn)
+
+(defimplementation create-socket (host port &key backlog)
+  (ccl:make-socket :connect :passive :local-port port
+                   :local-host host :reuse-address t
+                   :backlog (or backlog 5)))
+
+(defimplementation local-port (socket)
+  (ccl:local-port socket))
+
+(defimplementation close-socket (socket)
+  (close socket))
+
+(defimplementation accept-connection (socket &key external-format
+                                      buffering timeout)
+  (declare (ignore buffering timeout))
+  (let ((stream-args (and external-format
+                          `(:external-format ,external-format))))
+    (ccl:accept-connection socket :wait t :stream-args stream-args)))
+
+(defvar *external-format-to-coding-system*
+  '((:iso-8859-1
+     "latin-1" "latin-1-unix" "iso-latin-1-unix"
+     "iso-8859-1" "iso-8859-1-unix")
+    (:utf-8 "utf-8" "utf-8-unix")))
+
+(defimplementation find-external-format (coding-system)
+  (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+                  *external-format-to-coding-system*)))
+
+(defimplementation socket-fd (stream)
+  (ccl::ioblock-device (ccl::stream-ioblock stream t)))
+
+;;; Unix signals
+
+(defimplementation getpid ()
+  (ccl::getpid))
+
+(defimplementation lisp-implementation-type-name ()
+  "ccl")
+
+;;; Arglist
+
+(defimplementation arglist (fname)
+  (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil))
+                                           (ccl:arglist fname))
+    (if binding
+      arglist
+      :not-available)))
+
+(defimplementation function-name (function)
+  (ccl:function-name function))
+
+(defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
+  (let ((flags (ccl:declaration-information decl-identifier)))
+    (if flags
+        `(&any ,flags)
+        (call-next-method))))
+
+;;; Compilation
+
+(defun handle-compiler-warning (condition)
+  "Resignal a ccl:compiler-warning as swank/backend:compiler-warning."
+  (signal 'compiler-condition
+          :original-condition condition
+          :message (compiler-warning-short-message condition)
+          :source-context nil
+          :severity (compiler-warning-severity condition)
+          :location (source-note-to-source-location
+                     (ccl:compiler-warning-source-note condition)
+                     (lambda () "Unknown source")
+                     (ccl:compiler-warning-function-name condition))))
+
+(defgeneric compiler-warning-severity (condition))
+(defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
+(defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning)
+
+(defgeneric compiler-warning-short-message (condition))
+
+;; Pretty much the same as ccl:report-compiler-warning but
+;; without the source position and function name stuff.
+(defmethod compiler-warning-short-message ((c ccl:compiler-warning))
+  (with-output-to-string (stream)
+    (ccl:report-compiler-warning c stream :short t)))
+
+;; Needed because `ccl:report-compiler-warning' would return
+;; "Nonspecific warning".
+(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause))
+  (princ-to-string c))
+
+(defimplementation call-with-compilation-hooks (function)
+  (handler-bind ((ccl:compiler-warning 'handle-compiler-warning))
+    (let ((ccl:*merge-compiler-warnings* nil))
+      (funcall function))))
+
+(defimplementation swank-compile-file (input-file output-file
+                                       load-p external-format
+                                       &key policy)
+  (declare (ignore policy))
+  (with-compilation-hooks ()
+    (compile-file input-file
+                  :output-file output-file
+                  :load load-p
+                  :external-format external-format)))
+
+;; Use a temp file rather than in-core compilation in order to handle
+;; eval-when's as compile-time.
+(defimplementation swank-compile-string (string &key buffer position filename
+                                                line column policy)
+  (declare (ignore line column policy))
+  (with-compilation-hooks ()
+    (let ((temp-file-name (ccl:temp-pathname))
+          (ccl:*save-source-locations* t))
+      (unwind-protect
+           (progn
+             (with-open-file (s temp-file-name :direction :output
+                                :if-exists :error :external-format :utf-8)
+               (write-string string s))
+             (let ((binary-filename (compile-temp-file
+                                     temp-file-name filename buffer position)))
+               (delete-file binary-filename)))
+        (delete-file temp-file-name)))))
+
+(defvar *temp-file-map* (make-hash-table :test #'equal)
+  "A mapping from tempfile names to Emacs buffer names.")
+
+(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
+  (compile-file temp-file-name
+                :load t
+                :compile-file-original-truename
+                (or buffer-file-name
+                    (progn
+                      (setf (gethash temp-file-name *temp-file-map*)
+                            buffer-name)
+                      temp-file-name))
+                :compile-file-original-buffer-offset (1- offset)
+                :external-format :utf-8))
+
+(defimplementation save-image (filename &optional restart-function)
+  (ccl:save-application filename :toplevel-function restart-function))
+
+;;; Cross-referencing
+
+(defun xref-locations (relation name &optional inverse)
+  (delete-duplicates
+   (mapcan #'find-definitions
+           (if inverse
+             (ccl::get-relation relation name :wild :exhaustive t)
+             (ccl::get-relation relation :wild name :exhaustive t)))
+   :test 'equal))
+
+(defimplementation who-binds (name)
+  (xref-locations :binds name))
+
+(defimplementation who-macroexpands (name)
+  (xref-locations :macro-calls name t))
+
+(defimplementation who-references (name)
+  (remove-duplicates
+   (append (xref-locations :references name)
+           (xref-locations :sets name)
+           (xref-locations :binds name))
+   :test 'equal))
+
+(defimplementation who-sets (name)
+  (xref-locations :sets name))
+
+(defimplementation who-calls (name)
+  (remove-duplicates
+   (append
+    (xref-locations :direct-calls name)
+    (xref-locations :indirect-calls name)
+    (xref-locations :macro-calls name t))
+   :test 'equal))
+
+(defimplementation who-specializes (class)
+  (when (symbolp class)
+    (setq class (find-class class nil)))
+  (when class
+    (delete-duplicates
+     (mapcar (lambda (m)
+               (car (find-definitions m)))
+             (ccl:specializer-direct-methods class))
+     :test 'equal)))
+
+(defimplementation list-callees (name)
+  (remove-duplicates
+   (append
+   (xref-locations :direct-calls name t)
+   (xref-locations :macro-calls name nil))
+   :test 'equal))
+
+(defimplementation list-callers (symbol)
+  (delete-duplicates
+   (mapcan #'find-definitions (ccl:caller-functions symbol))
+   :test #'equal))
+
+;;; Profiling (alanr: lifted from swank-clisp)
+
+(defimplementation profile (fname)
+  (eval `(swank-monitor:monitor ,fname)))		;monitor is a macro
+
+(defimplementation profiled-functions ()
+  swank-monitor:*monitored-functions*)
+
+(defimplementation unprofile (fname)
+  (eval `(swank-monitor:unmonitor ,fname)))	;unmonitor is a macro
+
+(defimplementation unprofile-all ()
+  (swank-monitor:unmonitor))
+
+(defimplementation profile-report ()
+  (swank-monitor:report-monitoring))
+
+(defimplementation profile-reset ()
+  (swank-monitor:reset-all-monitoring))
+
+(defimplementation profile-package (package callers-p methods)
+  (declare (ignore callers-p methods))
+  (swank-monitor:monitor-all package))
+
+;;; Debugging
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+  (let* (;;(*debugger-hook* nil)
+         ;; don't let error while printing error take us down
+         (ccl:*signal-printing-errors* nil))
+    (funcall debugger-loop-fn)))
+
+;; This is called for an async interrupt and is running in a random
+;; thread not selected by the user, so don't use thread-local vars
+;; such as *emacs-connection*.
+(defun find-repl-thread ()
+  (let* ((*break-on-signals* nil)
+         (conn (swank::default-connection)))
+    (and (swank::multithreaded-connection-p conn)
+         (swank::mconn.repl-thread conn))))
+
+(defimplementation call-with-debugger-hook (hook fun)
+  (let ((*debugger-hook* hook)
+        (ccl:*break-hook* hook)
+        (ccl:*select-interactive-process-hook* 'find-repl-thread))
+    (funcall fun)))
+
+(defimplementation install-debugger-globally (function)
+  (setq *debugger-hook* function)
+  (setq ccl:*break-hook* function)
+  (setq ccl:*select-interactive-process-hook* 'find-repl-thread)
+  )
+
+(defun map-backtrace (function &optional
+                      (start-frame-number 0)
+                      end-frame-number)
+  "Call FUNCTION passing information about each stack frame
+ from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
+  (let ((end-frame-number (or end-frame-number most-positive-fixnum)))
+    (ccl:map-call-frames function
+                         :origin ccl:*top-error-frame*
+                         :start-frame-number start-frame-number
+                         :count (- end-frame-number start-frame-number))))
+
+(defimplementation compute-backtrace (start-frame-number end-frame-number)
+  (let (result)
+    (map-backtrace (lambda (p context)
+                     (push (list :frame p context) result))
+                   start-frame-number end-frame-number)
+    (nreverse result)))
+
+(defimplementation print-frame (frame stream)
+  (assert (eq (first frame) :frame))
+  (destructuring-bind (p context) (rest frame)
+    (let ((lfun (ccl:frame-function p context)))
+      (format stream "(~S" (or (ccl:function-name lfun) lfun))
+      (let* ((unavailable (cons nil nil))
+             (args (ccl:frame-supplied-arguments p context
+                                                 :unknown-marker unavailable)))
+        (declare (dynamic-extent unavailable))
+        (if (eq args unavailable)
+            (format stream " #<Unknown Arguments>")
+            (dolist (arg args)
+              (if (eq arg unavailable)
+                  (format stream " #<Unavailable>")
+                  (format stream " ~s" arg)))))
+      (format stream ")"))))
+
+(defmacro with-frame ((p context) frame-number &body body)
+  `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
+
+(defun call/frame (frame-number if-found)
+  (map-backtrace
+   (lambda (p context)
+     (return-from call/frame
+       (funcall if-found p context)))
+   frame-number))
+
+(defimplementation frame-call (frame-number)
+  (with-frame (p context) frame-number
+    (with-output-to-string (stream)
+      (print-frame (list :frame p context) stream))))
+
+(defimplementation frame-var-value (frame var)
+  (with-frame (p context) frame
+    (cdr (nth var (ccl:frame-named-variables p context)))))
+
+(defimplementation frame-locals (index)
+  (with-frame (p context) index
+    (loop for (name . value) in (ccl:frame-named-variables p context)
+          collect (list :name name :value value :id 0))))
+
+(defimplementation frame-source-location (index)
+  (with-frame (p context) index
+    (multiple-value-bind (lfun pc) (ccl:frame-function p context)
+      (if pc
+        (pc-source-location lfun pc)
+        (function-source-location lfun)))))
+
+(defun function-name-package (name)
+  (etypecase name
+    (null nil)
+    (symbol (symbol-package name))
+    ((cons (eql ccl::traced)) (function-name-package (second name)))
+    ((cons (eql setf)) (symbol-package (second name)))
+    ((cons (eql :internal)) (function-name-package (car (last name))))
+    ((cons (and symbol (not keyword)) (or (cons list null)
+                                          (cons keyword (cons list null))))
+     (symbol-package (car name)))
+    (standard-method (function-name-package (ccl:method-name name)))))
+
+(defimplementation frame-package (frame-number)
+  (with-frame (p context) frame-number
+    (let* ((lfun (ccl:frame-function p context))
+           (name (ccl:function-name lfun)))
+      (function-name-package name))))
+
+(defimplementation eval-in-frame (form index)
+  (with-frame (p context) index
+    (let ((vars (ccl:frame-named-variables p context)))
+      (eval `(let ,(loop for (var . val) in vars collect `(,var ',val))
+               (declare (ignorable ,@(mapcar #'car vars)))
+               ,form)))))
+
+(defimplementation return-from-frame (index form)
+  (let ((values (multiple-value-list (eval-in-frame form index))))
+    (with-frame (p context) index
+       (declare (ignore context))
+       (ccl:apply-in-frame p #'values values))))
+
+(defimplementation restart-frame (index)
+  (with-frame (p context) index
+    (ccl:apply-in-frame p
+                        (ccl:frame-function p context)
+                        (ccl:frame-supplied-arguments p context))))
+
+(defimplementation disassemble-frame (the-frame-number)
+  (with-frame (p context) the-frame-number
+    (multiple-value-bind (lfun pc) (ccl:frame-function p context)
+      (format t "LFUN: ~a~%PC: ~a  FP: #x~x  CONTEXT: ~a~%" lfun pc p context)
+      (disassemble lfun))))
+
+;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
+;; contains some interesting details:
+;;
+;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
+;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
+;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT.  The start and end
+;; positions are file positions (not character positions).  The text will
+;; be NIL unless text recording was on at read-time.  If the original
+;; file is still available, you can force missing source text to be read
+;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
+;;
+;; Source-note's are associated with definitions (via record-source-file)
+;; and also stored in function objects (including anonymous and nested
+;; functions).  The former can be retrieved via
+;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
+;;
+;; The recording behavior is controlled by the new variable
+;; CCL:*SAVE-SOURCE-LOCATIONS*:
+;;
+;;   If NIL, don't store source-notes in function objects, and store only
+;;   the filename for definitions (the latter only if
+;;   *record-source-file* is true).
+;;
+;;   If T, store source-notes, including a copy of the original source
+;;   text, for function objects and definitions (the latter only if
+;;   *record-source-file* is true).
+;;
+;;   If :NO-TEXT, store source-notes, but without saved text, for
+;;   function objects and defintions (the latter only if
+;;   *record-source-file* is true).  This is the default.
+;;
+;; PC to source mapping is controlled by the new variable
+;; CCL:*RECORD-PC-MAPPING*.  If true (the default), functions store a
+;; compressed table mapping pc offsets to corresponding source locations.
+;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
+;; which returns a source-note for the source at offset pc in the
+;; function.
+
+(defun function-source-location (function)
+  (source-note-to-source-location
+   (or (ccl:function-source-note function)
+       (function-name-source-note function))
+   (lambda ()
+     (format nil "Function has no source note: ~A" function))
+   (ccl:function-name function)))
+
+(defun pc-source-location (function pc)
+  (source-note-to-source-location
+   (or (ccl:find-source-note-at-pc function pc)
+       (ccl:function-source-note function)
+       (function-name-source-note function))
+   (lambda ()
+     (format nil "No source note at PC: ~a[~d]" function pc))
+   (ccl:function-name function)))
+
+(defun function-name-source-note (fun)
+  (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
+    (and defs
+         (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
+           (declare (ignore type name srclocs))
+           srcloc))))
+
+(defun source-note-to-source-location (source if-nil-thunk &optional name)
+  (labels ((filename-to-buffer (filename)
+             (cond ((gethash filename *temp-file-map*)
+                    (list :buffer (gethash filename *temp-file-map*)))
+                   ((probe-file filename)
+                    (list :file (ccl:native-translated-namestring
+                                 (truename filename))))
+                   (t (error "File ~s doesn't exist" filename)))))
+    (handler-case
+        (cond ((ccl:source-note-p source)
+               (let* ((full-text (ccl:source-note-text source))
+                      (file-name (ccl:source-note-filename source))
+                      (start-pos (ccl:source-note-start-pos source)))
+                 (make-location
+                  (when file-name (filename-to-buffer (pathname file-name)))
+                  (when start-pos (list :position (1+ start-pos)))
+                  (when full-text
+                    (list :snippet (subseq full-text 0
+                                           (min 40 (length full-text))))))))
+              ((and source name)
+               ;; This branch is probably never used
+               (make-location
+                (filename-to-buffer source)
+                (list :function-name (princ-to-string
+                                      (if (functionp name)
+                                          (ccl:function-name name)
+                                          name)))))
+              (t `(:error ,(funcall if-nil-thunk))))
+      (error (c) `(:error ,(princ-to-string c))))))
+
+(defun alphatizer-definitions (name)
+  (let ((alpha (gethash name ccl::*nx1-alphatizers*)))
+    (and alpha (ccl:find-definition-sources alpha))))
+
+(defun p2-definitions (name)
+  (let ((nx1-op (gethash name ccl::*nx1-operators*)))
+    (and nx1-op
+         (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) )
+           (and (array-in-bounds-p dispatch nx1-op)
+                (let ((p2 (aref dispatch nx1-op)))
+                  (and p2
+                       (ccl:find-definition-sources p2))))))))
+
+(defimplementation find-definitions (name)
+  (let ((defs (append (or (ccl:find-definition-sources name)
+                          (and (symbolp name)
+                               (fboundp name)
+                               (ccl:find-definition-sources
+                                (symbol-function name))))
+                      (alphatizer-definitions name)
+                      (p2-definitions name))))
+    (loop for ((type . name) . sources) in defs
+          collect (list (definition-name type name)
+                        (source-note-to-source-location
+                         (find-if-not #'null sources)
+                         (lambda () "No source-note available")
+                         name)))))
+
+(defimplementation find-source-location (obj)
+  (let* ((defs (ccl:find-definition-sources obj))
+         (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
+                       (car defs)))
+         (note (find-if-not #'null (cdr best-def))))
+    (when note
+      (source-note-to-source-location
+       note
+       (lambda () "No source note available")))))
+
+(defun definition-name (type object)
+  (case (ccl:definition-type-name type)
+    (method (ccl:name-of object))
+    (t (list (ccl:definition-type-name type) (ccl:name-of object)))))
+
+;;; Utilities
+
+(defimplementation describe-symbol-for-emacs (symbol)
+  (let ((result '()))
+    (flet ((doc (kind &optional (sym symbol))
+             (or (documentation sym kind) :not-documented))
+           (maybe-push (property value)
+             (when value
+               (setf result (list* property value result)))))
+      (maybe-push
+       :variable (when (boundp symbol)
+                   (doc 'variable)))
+      (maybe-push
+       :function (if (fboundp symbol)
+                     (doc 'function)))
+      (maybe-push
+       :setf (let ((setf-function-name (ccl:setf-function-spec-name
+                                        `(setf ,symbol))))
+               (when (fboundp setf-function-name)
+                 (doc 'function setf-function-name))))
+      (maybe-push
+       :type (when (ccl:type-specifier-p symbol)
+               (doc 'type)))
+      result)))
+
+(defimplementation describe-definition (symbol namespace)
+  (ecase namespace
+    (:variable
+     (describe symbol))
+    ((:function :generic-function)
+     (describe (symbol-function symbol)))
+    (:setf
+     (describe (ccl:setf-function-spec-name `(setf ,symbol))))
+    (:class
+     (describe (find-class symbol)))
+    (:type
+     (describe (or (find-class symbol nil) symbol)))))
+
+;; spec ::= (:defmethod <name> {<qualifier>}* ({<specializer>}*))
+(defun parse-defmethod-spec (spec)
+  (values (second spec)
+          (subseq spec 2 (position-if #'consp spec))
+          (find-if #'consp (cddr spec))))
+
+(defimplementation toggle-trace (spec)
+  "We currently ignore just about everything."
+  (let ((what (ecase (first spec)
+                ((setf)
+                 spec)
+                ((:defgeneric)
+                 (second spec))
+                ((:defmethod)
+                 (multiple-value-bind (name qualifiers specializers)
+                     (parse-defmethod-spec spec)
+                   (find-method (fdefinition name)
+                                qualifiers
+                                specializers))))))
+    (cond ((member what (trace) :test #'equal)
+           (ccl::%untrace what)
+           (format nil "~S is now untraced." what))
+          (t
+           (ccl:trace-function what)
+           (format nil "~S is now traced." what)))))
+
+;;; Macroexpansion
+
+(defimplementation macroexpand-all (form &optional env)
+  (ccl:macroexpand-all form env))
+
+;;;; Inspection
+
+(defun comment-type-p (type)
+  (or (eq type :comment)
+      (and (consp type) (eq (car type) :comment))))
+
+(defmethod emacs-inspect ((o t))
+  (let* ((inspector:*inspector-disassembly* t)
+         (i (inspector:make-inspector o))
+         (count (inspector:compute-line-count i)))
+    (loop for l from 0 below count append
+          (multiple-value-bind (value label type) (inspector:line-n i l)
+            (etypecase type
+              ((member nil :normal)
+               `(,(or label "") (:value ,value) (:newline)))
+              ((member :colon)
+               (label-value-line label value))
+              ((member :static)
+               (list (princ-to-string label) " " `(:value ,value) '(:newline)))
+              ((satisfies comment-type-p)
+               (list (princ-to-string label) '(:newline))))))))
+
+(defmethod emacs-inspect :around ((o t))
+  (if (or (uvector-inspector-p o)
+          (not (ccl:uvectorp o)))
+      (call-next-method)
+      (let ((value (call-next-method)))
+        (cond ((listp value)
+               (append value
+                       `((:newline)
+                         (:value ,(make-instance 'uvector-inspector :object o)
+                                 "Underlying UVECTOR"))))
+              (t value)))))
+
+(defmethod emacs-inspect ((f function))
+  (append
+   (label-value-line "Name" (function-name f))
+   `("Its argument list is: "
+     ,(princ-to-string (arglist f)) (:newline))
+   (label-value-line "Documentation" (documentation  f t))
+   (when (function-lambda-expression f)
+     (label-value-line "Lambda Expression"
+                       (function-lambda-expression f)))
+   (when (ccl:function-source-note f)
+     (label-value-line "Source note"
+                       (ccl:function-source-note f)))
+   (when (typep f 'ccl:compiled-lexical-closure)
+     (append
+      (label-value-line "Inner function" (ccl::closure-function f))
+      '("Closed over values:" (:newline))
+      (loop for (name value) in (ccl::closure-closed-over-values f)
+            append (label-value-line (format nil " ~a" name)
+                                     value))))))
+
+(defclass uvector-inspector ()
+  ((object :initarg :object)))
+
+(defgeneric uvector-inspector-p (object)
+  (:method ((object t)) nil)
+  (:method ((object uvector-inspector)) t))
+
+(defmethod emacs-inspect ((uv uvector-inspector))
+  (with-slots (object) uv
+    (loop for i below (ccl:uvsize object) append
+          (label-value-line (princ-to-string i) (ccl:uvref object i)))))
+
+(defimplementation type-specifier-p (symbol)
+  (or (ccl:type-specifier-p symbol)
+      (not (eq (type-specifier-arglist symbol) :not-available))))
+
+;;; Multiprocessing
+
+(defvar *known-processes*
+  (make-hash-table :size 20 :weak :key :test #'eq)
+  "A map from threads to mailboxes.")
+
+(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
+
+(defstruct (mailbox (:conc-name mailbox.))
+  (mutex (ccl:make-lock "thread mailbox"))
+  (semaphore (ccl:make-semaphore))
+  (queue '() :type list))
+
+(defimplementation spawn (fun &key name)
+  (ccl:process-run-function (or name "Anonymous (Swank)")
+                            fun))
+
+(defimplementation thread-id (thread)
+  (ccl:process-serial-number thread))
+
+(defimplementation find-thread (id)
+  (find id (ccl:all-processes) :key #'ccl:process-serial-number))
+
+(defimplementation thread-name (thread)
+  (ccl:process-name thread))
+
+(defimplementation thread-status (thread)
+  (format nil "~A" (ccl:process-whostate thread)))
+
+(defimplementation thread-attributes (thread)
+   (list :priority (ccl:process-priority thread)))
+
+(defimplementation make-lock (&key name)
+  (ccl:make-lock name))
+
+(defimplementation call-with-lock-held (lock function)
+  (ccl:with-lock-grabbed (lock)
+    (funcall function)))
+
+(defimplementation current-thread ()
+  ccl:*current-process*)
+
+(defimplementation all-threads ()
+  (ccl:all-processes))
+
+(defimplementation kill-thread (thread)
+  ;;(ccl:process-kill thread) ; doesn't cut it
+  (ccl::process-initial-form-exited thread :kill))
+
+(defimplementation thread-alive-p (thread)
+  (not (ccl:process-exhausted-p thread)))
+
+(defimplementation interrupt-thread (thread function)
+  (ccl:process-interrupt
+   thread
+   (lambda ()
+     (let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
+       (funcall function)))))
+
+(defun mailbox (thread)
+  (ccl:with-lock-grabbed (*known-processes-lock*)
+    (or (gethash thread *known-processes*)
+        (setf (gethash thread *known-processes*) (make-mailbox)))))
+
+(defimplementation send (thread message)
+  (assert message)
+  (let* ((mbox (mailbox thread))
+         (mutex (mailbox.mutex mbox)))
+    (ccl:with-lock-grabbed (mutex)
+      (setf (mailbox.queue mbox)
+            (nconc (mailbox.queue mbox) (list message)))
+      (ccl:signal-semaphore (mailbox.semaphore mbox)))))
+
+(defimplementation wake-thread (thread)
+  (let* ((mbox (mailbox thread))
+         (mutex (mailbox.mutex mbox)))
+    (ccl:with-lock-grabbed (mutex)
+      (ccl:signal-semaphore (mailbox.semaphore mbox)))))
+
+(defimplementation receive-if (test &optional timeout)
+  (let* ((mbox (mailbox ccl:*current-process*))
+         (mutex (mailbox.mutex mbox)))
+    (assert (or (not timeout) (eq timeout t)))
+    (loop
+     (check-slime-interrupts)
+     (ccl:with-lock-grabbed (mutex)
+       (let* ((q (mailbox.queue mbox))
+              (tail (member-if test q)))
+         (when tail
+           (setf (mailbox.queue mbox)
+                 (nconc (ldiff q tail) (cdr tail)))
+           (return (car tail)))))
+     (when (eq timeout t) (return (values nil t)))
+     (ccl:wait-on-semaphore (mailbox.semaphore mbox)))))
+
+(let ((alist '())
+      (lock (ccl:make-lock "register-thread")))
+
+  (defimplementation register-thread (name thread)
+    (declare (type symbol name))
+    (ccl:with-lock-grabbed (lock)
+      (etypecase thread
+        (null
+         (setf alist (delete name alist :key #'car)))
+        (ccl:process
+         (let ((probe (assoc name alist)))
+           (cond (probe (setf (cdr probe) thread))
+                 (t (setf alist (acons name thread alist))))))))
+    nil)
+
+  (defimplementation find-registered (name)
+    (ccl:with-lock-grabbed (lock)
+      (cdr (assoc name alist)))))
+
+(defimplementation set-default-initial-binding (var form)
+  (eval `(ccl::def-standard-initial-binding ,var ,form)))
+
+(defimplementation quit-lisp ()
+  (ccl:quit))
+
+(defimplementation set-default-directory (directory)
+  (let ((dir (truename (merge-pathnames directory))))
+    (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
+    (ccl:cwd dir)
+    (default-directory)))
+
+;;; Weak datastructures
+
+(defimplementation make-weak-key-hash-table (&rest args)
+  (apply #'make-hash-table :weak :key args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+  (apply #'make-hash-table :weak :value args))
+
+(defimplementation hash-table-weakness (hashtable)
+  (ccl:hash-table-weak-p hashtable))
+
+(pushnew 'deinit-log-output ccl:*save-exit-functions*)

sources_non_forked/slimv/slime/swank/clasp.lisp

@@ -0,0 +1,712 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-clasp.lisp --- SLIME backend for CLASP.
+;;;
+;;; This code has been placed in the Public Domain.  All warranties
+;;; are disclaimed.
+;;;
+
+;;; Administrivia
+
+(defpackage swank/clasp
+  (:use cl swank/backend))
+
+(in-package swank/clasp)
+
+#+(or)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setq swank::*log-output* (open "/tmp/slime.log" :direction :output))
+  (setq swank:*log-events* t))
+
+(defmacro slime-dbg (fmt &rest args)
+  `(swank::log-event "slime-dbg ~a ~a~%" mp:*current-process* (apply #'format nil ,fmt ,args)))
+
+;; Hard dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require 'sockets))
+
+;; Soft dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (probe-file "sys:profile.fas")
+    (require :profile)
+    (pushnew :profile *features*))
+  (when (probe-file "sys:serve-event")
+    (require :serve-event)
+    (pushnew :serve-event *features*)))
+
+(declaim (optimize (debug 3)))
+
+;;; Swank-mop
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (import-swank-mop-symbols :clos nil))
+
+(defimplementation gray-package-name ()
+  "GRAY")
+
+
+;;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+  :spawn
+#|  #+threads :spawn
+  #-threads nil
+|#
+  )
+
+(defun resolve-hostname (name)
+  (car (sb-bsd-sockets:host-ent-addresses
+        (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port &key backlog)
+  (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+			       :type :stream
+			       :protocol :tcp)))
+    (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+    (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
+    (sb-bsd-sockets:socket-listen socket (or backlog 5))
+    socket))
+
+(defimplementation local-port (socket)
+  (nth-value 1 (sb-bsd-sockets:socket-name socket)))
+
+(defimplementation close-socket (socket)
+  (sb-bsd-sockets:socket-close socket))
+
+(defimplementation accept-connection (socket
+                                      &key external-format
+                                      buffering timeout)
+  (declare (ignore timeout))
+  (sb-bsd-sockets:socket-make-stream (accept socket)
+                                     :output t
+                                     :input t
+                                     :buffering (ecase buffering
+                                                  ((t) :full)
+                                                  ((nil) :none)
+                                                  (:line :line))
+                                     :element-type (if external-format
+                                                       'character 
+                                                       '(unsigned-byte 8))
+                                     :external-format external-format))
+(defun accept (socket)
+  "Like socket-accept, but retry on EAGAIN."
+  (loop (handler-case
+            (return (sb-bsd-sockets:socket-accept socket))
+          (sb-bsd-sockets:interrupted-error ()))))
+
+(defimplementation socket-fd (socket)
+  (etypecase socket
+    (fixnum socket)
+    (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
+    (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
+    (file-stream (si:file-stream-fd socket))))
+
+(defvar *external-format-to-coding-system*
+  '((:latin-1
+     "latin-1" "latin-1-unix" "iso-latin-1-unix" 
+     "iso-8859-1" "iso-8859-1-unix")
+    (:utf-8 "utf-8" "utf-8-unix")))
+
+(defun external-format (coding-system)
+  (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+                      *external-format-to-coding-system*))
+      (find coding-system (ext:all-encodings) :test #'string-equal)))
+
+(defimplementation find-external-format (coding-system)
+  #+unicode (external-format coding-system)
+  ;; Without unicode support, CLASP uses the one-byte encoding of the
+  ;; underlying OS, and will barf on anything except :DEFAULT.  We
+  ;; return NIL here for known multibyte encodings, so
+  ;; SWANK:CREATE-SERVER will barf.
+  #-unicode (let ((xf (external-format coding-system)))
+              (if (member xf '(:utf-8))
+                  nil
+                  :default)))
+
+
+;;;; Unix Integration
+
+;;; If CLASP is built with thread support, it'll spawn a helper thread
+;;; executing the SIGINT handler. We do not want to BREAK into that
+;;; helper but into the main thread, though. This is coupled with the
+;;; current choice of NIL as communication-style in so far as CLASP's
+;;; main-thread is also the Slime's REPL thread.
+
+#+clasp-working
+(defimplementation call-with-user-break-handler (real-handler function)
+  (let ((old-handler #'si:terminal-interrupt))
+    (setf (symbol-function 'si:terminal-interrupt)
+          (make-interrupt-handler real-handler))
+    (unwind-protect (funcall function)
+      (setf (symbol-function 'si:terminal-interrupt) old-handler))))
+
+#+threads
+(defun make-interrupt-handler (real-handler)
+  (let ((main-thread (find 'si:top-level (mp:all-processes)
+                           :key #'mp:process-name)))
+    #'(lambda (&rest args)
+        (declare (ignore args))
+        (mp:interrupt-process main-thread real-handler))))
+
+#-threads
+(defun make-interrupt-handler (real-handler)
+  #'(lambda (&rest args)
+      (declare (ignore args))
+      (funcall real-handler)))
+
+
+(defimplementation getpid ()
+  (si:getpid))
+
+(defimplementation set-default-directory (directory)
+  (ext:chdir (namestring directory))  ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
+  (default-directory))
+
+(defimplementation default-directory ()
+  (namestring (ext:getcwd)))
+
+(defimplementation quit-lisp ()
+  (core:quit))
+
+
+
+;;; Instead of busy waiting with communication-style NIL, use select()
+;;; on the sockets' streams.
+#+serve-event
+(progn
+  (defun poll-streams (streams timeout)
+    (let* ((serve-event::*descriptor-handlers*
+            (copy-list serve-event::*descriptor-handlers*))
+           (active-fds '())
+           (fd-stream-alist
+            (loop for s in streams
+                  for fd = (socket-fd s)
+                  collect (cons fd s)
+                  do (serve-event:add-fd-handler fd :input
+                                                 #'(lambda (fd)
+                                                     (push fd active-fds))))))
+      (serve-event:serve-event timeout)
+      (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))
+
+  (defimplementation wait-for-input (streams &optional timeout)
+    (assert (member timeout '(nil t)))
+    (loop
+       (cond ((check-slime-interrupts) (return :interrupt))
+             (timeout (return (poll-streams streams 0)))
+             (t
+              (when-let (ready (poll-streams streams 0.2))
+                        (return ready))))))  
+
+) ; #+serve-event (progn ...
+
+#-serve-event
+(defimplementation wait-for-input (streams &optional timeout)
+  (assert (member timeout '(nil t)))
+  (loop
+   (cond ((check-slime-interrupts) (return :interrupt))
+         (timeout (return (remove-if-not #'listen streams)))
+         (t
+          (let ((ready (remove-if-not #'listen streams)))
+            (if ready (return ready))
+            (sleep 0.1))))))
+
+
+;;;; Compilation
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+
+(defun condition-severity (condition)
+  (etypecase condition
+    (cmp:redefined-function-warning :redefinition)
+    (style-warning                  :style-warning)
+    (warning                        :warning)
+    (reader-error                   :read-error)
+    (error                          :error)))
+
+(defun condition-location (origin)
+  (if (null origin)
+      (make-error-location "No error location available")
+      ;; NOTE: If we're compiling in a buffer, the origin
+      ;; will already be set up with the offset correctly
+      ;; due to the :source-debug parameters from
+      ;; swank-compile-string (below).
+      (make-file-location
+       (core:file-scope-pathname
+        (core:file-scope origin))
+       (core:source-pos-info-filepos origin))))
+
+(defun signal-compiler-condition (condition origin)
+  (signal 'compiler-condition
+          :original-condition condition
+          :severity (condition-severity condition)
+          :message (princ-to-string condition)
+          :location (condition-location origin)))
+
+(defun handle-compiler-condition (condition)
+  ;; First resignal warnings, so that outer handlers - which may choose to
+  ;; muffle this - get a chance to run.
+  (when (typep condition 'warning)
+    (signal condition))
+  (signal-compiler-condition (cmp:deencapsulate-compiler-condition condition)
+                             (cmp:compiler-condition-origin condition)))
+
+(defimplementation call-with-compilation-hooks (function)
+  (handler-bind
+      (((or error warning) #'handle-compiler-condition))
+    (funcall function)))
+
+(defimplementation swank-compile-file (input-file output-file
+                                       load-p external-format
+                                       &key policy)
+  (declare (ignore policy))
+  (format t "Compiling file input-file = ~a   output-file = ~a~%" input-file output-file)
+  ;; Ignore the output-file and generate our own
+  (let ((tmp-output-file (compile-file-pathname (si:mkstemp "TMP:clasp-swank-compile-file-"))))
+    (format t "Using tmp-output-file: ~a~%" tmp-output-file)
+    (multiple-value-bind (fasl warnings-p failure-p)
+        (with-compilation-hooks ()
+          (compile-file input-file :output-file tmp-output-file
+                        :external-format external-format))
+      (values fasl warnings-p
+              (or failure-p
+                  (when load-p
+                    (not (load fasl))))))))
+
+(defvar *tmpfile-map* (make-hash-table :test #'equal))
+
+(defun note-buffer-tmpfile (tmp-file buffer-name)
+  ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
+  (let ((tmp-namestring (namestring (truename tmp-file))))
+    (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
+    tmp-namestring))
+
+(defun tmpfile-to-buffer (tmp-file)
+  (gethash tmp-file *tmpfile-map*))
+
+(defimplementation swank-compile-string (string &key buffer position filename line column policy)
+  (declare (ignore column policy)) ;; We may use column in the future
+  (with-compilation-hooks ()
+    (let ((*buffer-name* buffer)        ; for compilation hooks
+          (*buffer-start-position* position))
+      (let ((tmp-file (si:mkstemp "TMP:clasp-swank-tmpfile-"))
+            (fasl-file)
+            (warnings-p)
+            (failure-p))
+        (unwind-protect
+             (with-open-file (tmp-stream tmp-file :direction :output
+                                                  :if-exists :supersede)
+               (write-string string tmp-stream)
+               (finish-output tmp-stream)
+               (multiple-value-setq (fasl-file warnings-p failure-p)
+                 (let ((truename (or filename (note-buffer-tmpfile tmp-file buffer))))
+                   (compile-file tmp-file
+                                 :source-debug-pathname (pathname truename)
+                                 ;; emacs numbers are 1-based instead of 0-based,
+                                 ;; so we have to subtract
+                                 :source-debug-lineno (1- line)
+                                 :source-debug-offset (1- position)))))
+          (when fasl-file (load fasl-file))
+          (when (probe-file tmp-file)
+            (delete-file tmp-file))
+          (when fasl-file
+            (delete-file fasl-file)))
+        (not failure-p)))))
+
+;;;; Documentation
+
+(defimplementation arglist (name)
+  (multiple-value-bind (arglist foundp)
+      (core:function-lambda-list name)     ;; Uses bc-split
+    (if foundp arglist :not-available)))
+
+(defimplementation function-name (f)
+  (typecase f
+    (generic-function (clos::generic-function-name f))
+    (function (ext:compiled-function-name f))))
+
+;; FIXME
+(defimplementation macroexpand-all (form &optional env)
+  (declare (ignore env))
+  (macroexpand form))
+
+;;; modified from sbcl.lisp
+(defimplementation collect-macro-forms (form &optional environment)
+  (let ((macro-forms '())
+        (compiler-macro-forms '())
+        (function-quoted-forms '()))
+    (format t "In collect-macro-forms~%")
+    (cmp:code-walk
+     (lambda (form environment)
+       (when (and (consp form)
+                  (symbolp (car form)))
+         (cond ((eq (car form) 'function)
+                (push (cadr form) function-quoted-forms))
+               ((member form function-quoted-forms)
+                nil)
+               ((macro-function (car form) environment)
+                (push form macro-forms))
+               ((not (eq form (core:compiler-macroexpand-1 form environment)))
+                (push form compiler-macro-forms))))
+       form)
+     form environment)
+    (values macro-forms compiler-macro-forms)))
+
+
+
+
+
+(defimplementation describe-symbol-for-emacs (symbol)
+  (let ((result '()))
+    (flet ((frob (type boundp)
+             (when (funcall boundp symbol)
+               (let ((doc (describe-definition symbol type)))
+                 (setf result (list* type doc result))))))
+      (frob :VARIABLE #'boundp)
+      (frob :FUNCTION #'fboundp)
+      (frob :CLASS (lambda (x) (find-class x nil))))
+    result))
+
+(defimplementation describe-definition (name type)
+  (case type
+    (:variable (documentation name 'variable))
+    (:function (documentation name 'function))
+    (:class (documentation name 'class))
+    (t nil)))
+
+(defimplementation type-specifier-p (symbol)
+  (or (subtypep nil symbol)
+      (not (eq (type-specifier-arglist symbol) :not-available))))
+
+
+;;; Debugging
+
+(defun make-invoke-debugger-hook (hook)
+  (when hook
+    #'(lambda (condition old-hook)
+        ;; Regard *debugger-hook* if set by user.
+        (if *debugger-hook*
+            nil         ; decline, *DEBUGGER-HOOK* will be tried next.
+            (funcall hook condition old-hook)))))
+
+(defimplementation install-debugger-globally (function)
+  (setq *debugger-hook* function)
+  (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
+
+(defimplementation call-with-debugger-hook (hook fun)
+  (let ((*debugger-hook* hook)
+        (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
+    (funcall fun)))
+
+(defvar *backtrace* '())
+
+;;; Commented out; it's not clear this is a good way of doing it. In
+;;; particular because it makes errors stemming from this file harder
+;;; to debug, and given the "young" age of CLASP's swank backend, that's
+;;; a bad idea.
+
+;; (defun in-swank-package-p (x)
+;;   (and
+;;    (symbolp x)
+;;    (member (symbol-package x)
+;;            (list #.(find-package :swank)
+;;                  #.(find-package :swank/backend)
+;;                  #.(ignore-errors (find-package :swank-mop))
+;;                  #.(ignore-errors (find-package :swank-loader))))
+;;    t))
+
+;; (defun is-swank-source-p (name)
+;;   (setf name (pathname name))
+;;   (pathname-match-p
+;;    name
+;;    (make-pathname :defaults swank-loader::*source-directory*
+;;                   :name (pathname-name name)
+;;                   :type (pathname-type name)
+;;                   :version (pathname-version name))))
+
+;; (defun is-ignorable-fun-p (x)
+;;   (or
+;;    (in-swank-package-p (frame-name x))
+;;    (multiple-value-bind (file position)
+;;        (ignore-errors (si::bc-file (car x)))
+;;      (declare (ignore position))
+;;      (if file (is-swank-source-p file)))))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+  (declare (type function debugger-loop-fn))
+  (clasp-debug:with-stack (stack)
+    (let ((*backtrace* (clasp-debug:list-stack stack)))
+      (funcall debugger-loop-fn))))
+
+(defimplementation compute-backtrace (start end)
+  (subseq *backtrace* start
+          (and (numberp end)
+               (min end (length *backtrace*)))))
+
+(defun frame-from-number (frame-number)
+  (elt *backtrace* frame-number))
+
+(defimplementation print-frame (frame stream)
+  (clasp-debug:prin1-frame-call frame stream))
+
+(defimplementation frame-source-location (frame-number)
+  (let ((csl (clasp-debug:frame-source-position (frame-from-number frame-number))))
+    (if (clasp-debug:code-source-line-pathname csl)
+        (make-location (list :file (namestring (clasp-debug:code-source-line-pathname csl)))
+                       (list :line (clasp-debug:code-source-line-line-number csl))
+                       '(:align t))
+        `(:error ,(format nil "No source for frame: ~a" frame-number)))))
+
+(defimplementation frame-locals (frame-number)
+  (loop for (var . value)
+          in (clasp-debug:frame-locals (frame-from-number frame-number))
+        for i from 0
+        collect (list :name var :id i :value value)))
+
+(defimplementation frame-var-value (frame-number var-number)
+  (let* ((frame (frame-from-number frame-number))
+         (locals (clasp-debug:frame-locals frame)))
+    (cdr (nth var-number locals))))
+
+(defimplementation disassemble-frame (frame-number)
+  (clasp-debug:disassemble-frame (frame-from-number frame-number)))
+
+(defimplementation eval-in-frame (form frame-number)
+  (let* ((frame (frame-from-number frame-number)))
+    (eval
+     `(let (,@(loop for (var . value)
+                      in (clasp-debug:frame-locals frame)
+                    collect `(,var ',value)))
+        (progn ,form)))))
+
+#+clasp-working
+(defimplementation gdb-initial-commands ()
+  ;; These signals are used by the GC.
+  #+linux '("handle SIGPWR  noprint nostop"
+            "handle SIGXCPU noprint nostop"))
+
+#+clasp-working
+(defimplementation command-line-args ()
+  (loop for n from 0 below (si:argc) collect (si:argv n)))
+
+
+;;;; Inspector
+
+;;; FIXME: Would be nice if it was possible to inspect objects
+;;; implemented in C.
+
+
+;;;; Definitions
+
+(defun make-file-location (file file-position)
+  ;; File positions in CL start at 0, but Emacs' buffer positions
+  ;; start at 1. We specify (:ALIGN T) because the positions comming
+  ;; from CLASP point at right after the toplevel form appearing before
+  ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
+  (make-location `(:file ,(namestring (translate-logical-pathname file)))
+                 `(:position ,(1+ file-position))
+                 `(:align t)))
+
+(defun make-buffer-location (buffer-name start-position &optional (offset 0))
+  (make-location `(:buffer ,buffer-name)
+                 `(:offset ,start-position ,offset)
+                 `(:align t)))
+
+(defun translate-location (location)
+  (make-location (list :file (namestring (ext:source-location-pathname location)))
+                 (list :position (ext:source-location-offset location))
+                 '(:align t)))
+
+(defun make-dspec (name location)
+  (list* (ext:source-location-definer location)
+         name
+         (ext:source-location-description location)))
+
+(defimplementation find-definitions (name)
+  (loop for kind in ext:*source-location-kinds*
+        for locations = (ext:source-location name kind)
+        when locations
+          nconc (loop for location in locations
+                      collect (list (make-dspec name location)
+                                    (translate-location location)))))
+
+(defun source-location (object)
+  (let ((location (ext:source-location object t)))
+    (when location
+      (translate-location (car location)))))
+
+(defimplementation find-source-location (object)
+  (or (source-location object)
+      (make-error-location "Source definition of ~S not found." object)))
+
+
+;;;; Profiling
+
+;;;; as clisp and ccl
+
+(defimplementation profile (fname)
+  (eval `(swank-monitor:monitor ,fname)))         ;monitor is a macro
+
+(defimplementation profiled-functions ()
+  swank-monitor:*monitored-functions*)
+
+(defimplementation unprofile (fname)
+  (eval `(swank-monitor:unmonitor ,fname)))       ;unmonitor is a macro
+
+(defimplementation unprofile-all ()
+  (swank-monitor:unmonitor))
+
+(defimplementation profile-report ()
+  (swank-monitor:report-monitoring))
+
+(defimplementation profile-reset ()
+  (swank-monitor:reset-all-monitoring))
+
+(defimplementation profile-package (package callers-p methods)
+  (declare (ignore callers-p methods))
+  (swank-monitor:monitor-all package))
+
+
+;;;; Threads
+
+#+threads
+(progn
+  (defvar *thread-id-counter* 0)
+
+  (defparameter *thread-id-map* (make-hash-table))
+
+  (defvar *thread-id-map-lock*
+    (mp:make-lock :name "thread id map lock"))
+
+  (defimplementation spawn (fn &key name)
+    (mp:process-run-function name fn))
+
+  (defimplementation thread-id (target-thread)
+    (block thread-id
+      (mp:with-lock (*thread-id-map-lock*)
+        ;; Does TARGET-THREAD have an id already?
+        (maphash (lambda (id thread-pointer)
+                   (let ((thread (si:weak-pointer-value thread-pointer)))
+                     (cond ((not thread)
+                            (remhash id *thread-id-map*))
+                           ((eq thread target-thread)
+                            (return-from thread-id id)))))
+                 *thread-id-map*)
+        ;; TARGET-THREAD not found in *THREAD-ID-MAP*
+        (let ((id (incf *thread-id-counter*))
+              (thread-pointer (si:make-weak-pointer target-thread)))
+          (setf (gethash id *thread-id-map*) thread-pointer)
+          id))))
+
+  (defimplementation find-thread (id)
+    (mp:with-lock (*thread-id-map-lock*)
+      (let* ((thread-ptr (gethash id *thread-id-map*))
+             (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
+        (unless thread
+          (remhash id *thread-id-map*))
+        thread)))
+
+  (defimplementation thread-name (thread)
+    (mp:process-name thread))
+
+  (defimplementation thread-status (thread)
+    (if (mp:process-active-p thread)
+        "RUNNING"
+        "STOPPED"))
+
+  (defimplementation make-lock (&key name)
+    (mp:make-recursive-mutex name))
+
+  (defimplementation call-with-lock-held (lock function)
+    (declare (type function function))
+    (mp:with-lock (lock) (funcall function)))
+
+  (defimplementation current-thread ()
+    mp:*current-process*)
+
+  (defimplementation all-threads ()
+    (mp:all-processes))
+
+  (defimplementation interrupt-thread (thread fn)
+    (mp:interrupt-process thread fn))
+
+  (defimplementation kill-thread (thread)
+    (mp:process-kill thread))
+
+  (defimplementation thread-alive-p (thread)
+    (mp:process-active-p thread))
+
+  (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
+  (defvar *mailboxes* (list))
+  (declaim (type list *mailboxes*))
+
+  (defstruct (mailbox (:conc-name mailbox.))
+    thread
+    (mutex (mp:make-lock :name "SLIMELCK"))
+    (cvar  (mp:make-condition-variable))
+    (queue '() :type list))
+
+  (defun mailbox (thread)
+    "Return THREAD's mailbox."
+    (mp:with-lock (*mailbox-lock*)
+      (or (find thread *mailboxes* :key #'mailbox.thread)
+          (let ((mb (make-mailbox :thread thread)))
+            (push mb *mailboxes*)
+            mb))))
+
+  (defimplementation wake-thread (thread)
+    (let* ((mbox (mailbox thread))
+           (mutex (mailbox.mutex mbox)))
+      (format t "About to with-lock in wake-thread~%")
+      (mp:with-lock (mutex)
+        (format t "In wake-thread~%")
+        (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
+  
+  (defimplementation send (thread message)
+    (let* ((mbox (mailbox thread))
+           (mutex (mailbox.mutex mbox)))
+      (swank::log-event "clasp.lisp: send message ~a    mutex: ~a~%" message mutex)
+      (swank::log-event "clasp.lisp:    (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex))
+      (swank::log-event "clasp.lisp:    (lock-count mutex) -> ~a~%" (mp:lock-count mutex))
+      (mp:with-lock (mutex)
+        (swank::log-event "clasp.lisp:  in with-lock   (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex))
+        (swank::log-event "clasp.lisp:  in with-lock   (lock-count mutex) -> ~a~%" (mp:lock-count mutex))
+        (setf (mailbox.queue mbox)
+              (nconc (mailbox.queue mbox) (list message)))
+        (swank::log-event "clasp.lisp: send about to broadcast~%")
+        (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
+
+  
+  (defimplementation receive-if (test &optional timeout)
+    (slime-dbg "Entered receive-if")
+    (let* ((mbox (mailbox (current-thread)))
+           (mutex (mailbox.mutex mbox)))
+      (slime-dbg "receive-if assert")
+      (assert (or (not timeout) (eq timeout t)))
+      (loop
+         (slime-dbg "receive-if check-slime-interrupts")
+         (check-slime-interrupts)
+         (slime-dbg "receive-if with-lock")
+         (mp:with-lock (mutex)
+           (let* ((q (mailbox.queue mbox))
+                  (tail (member-if test q)))
+             (when tail
+               (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
+               (return (car tail))))
+           (slime-dbg "receive-if when (eq")
+           (when (eq timeout t) (return (values nil t))) 
+           (slime-dbg "receive-if condition-variable-timedwait")
+           (mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait 0.2
+           (slime-dbg "came out of condition-variable-timedwait")
+           (core:check-pending-interrupts)))))
+
+  ) ; #+threads (progn ...
+
+
+(defmethod emacs-inspect ((object core:cxx-object))
+  (let ((encoded (core:encode object)))
+    (loop for (key . value) in encoded
+       append (list (string key) ": " (list :value value) (list :newline)))))
+
+(defmethod emacs-inspect ((object core:va-list))
+  (emacs-inspect (core:list-from-va-list object)))

sources_non_forked/slimv/slime/swank/clisp.lisp

@@ -0,0 +1,930 @@
+;;;; -*- indent-tabs-mode: nil -*-
+
+;;;; SWANK support for CLISP.
+
+;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
+
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License as
+;;;; published by the Free Software Foundation; either version 2 of
+;;;; the License, or (at your option) any later version.
+
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with this program; if not, write to the Free
+;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+;;;; MA 02111-1307, USA.
+
+;;; This is work in progress, but it's already usable.  Many things
+;;; are adapted from other swank-*.lisp, in particular from
+;;; swank-allegro (I don't use allegro at all, but it's the shortest
+;;; one and I found Helmut Eller's code there enlightening).
+
+;;; This code will work better with recent versions of CLISP (say, the
+;;; last release or CVS HEAD) while it may not work at all with older
+;;; versions.  It is reasonable to expect it to work on platforms with
+;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
+;;; systems, but also on Win32.  This backend uses the portable xref
+;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
+;;; are conveniently included in SLIME.
+
+;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
+
+(defpackage swank/clisp
+  (:use cl swank/backend))
+
+(in-package swank/clisp)
+
+(eval-when (:compile-toplevel)
+  (unless (string< "2.44" (lisp-implementation-version))
+    (error "Need at least CLISP version 2.44")))
+
+(defimplementation gray-package-name ()
+  "GRAY")
+
+;;;; if this lisp has the complete CLOS then we use it, otherwise we
+;;;; build up a "fake" swank-mop and then override the methods in the
+;;;; inspector.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *have-mop*
+    (and (find-package :clos)
+         (eql :external
+              (nth-value 1 (find-symbol (string ':standard-slot-definition)
+                                        :clos))))
+    "True in those CLISP images which have a complete MOP implementation."))
+
+#+#.(cl:if swank/clisp::*have-mop* '(cl:and) '(cl:or))
+(progn
+  (import-swank-mop-symbols :clos '(:slot-definition-documentation))
+
+  (defun swank-mop:slot-definition-documentation (slot)
+    (clos::slot-definition-documentation slot)))
+
+#-#.(cl:if swank/clisp::*have-mop* '(and) '(or))
+(defclass swank-mop:standard-slot-definition ()
+  ()
+  (:documentation
+   "Dummy class created so that swank.lisp will compile and load."))
+
+(let ((getpid (or (find-symbol "PROCESS-ID" :system)
+                  ;; old name prior to 2005-03-01, clisp <= 2.33.2
+                  (find-symbol "PROGRAM-ID" :system)
+                  #+win32 ; integrated into the above since 2005-02-24
+                  (and (find-package :win32) ; optional modules/win32
+                       (find-symbol "GetCurrentProcessId" :win32)))))
+  (defimplementation getpid () ; a required interface
+    (cond
+      (getpid (funcall getpid))
+      #+win32 ((ext:getenv "PID")) ; where does that come from?
+      (t -1))))
+
+(defimplementation call-with-user-break-handler (handler function)
+  (handler-bind ((system::simple-interrupt-condition
+                  (lambda (c)
+                    (declare (ignore c))
+                    (funcall handler)
+                    (when (find-restart 'socket-status)
+                      (invoke-restart (find-restart 'socket-status)))
+                    (continue))))
+    (funcall function)))
+
+(defimplementation lisp-implementation-type-name ()
+  "clisp")
+
+(defimplementation set-default-directory (directory)
+  (setf (ext:default-directory) directory)
+  (namestring (setf *default-pathname-defaults* (ext:default-directory))))
+
+(defimplementation filename-to-pathname (string)
+  (cond ((member :cygwin *features*)
+         (parse-cygwin-filename string))
+        (t (parse-namestring string))))
+
+(defun parse-cygwin-filename (string)
+  (multiple-value-bind (match _ drive absolute)
+      (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t)
+    (declare (ignore _))
+    (assert (and match (if drive absolute t)) ()
+            "Invalid filename syntax: ~a" string)
+    (let* ((sans-prefix (subseq string (regexp:match-end match)))
+           (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix)))
+           (path (loop for name in path collect
+                       (cond ((equal name "..") ':back)
+                             (t name))))
+           (directoryp (or (equal string "")
+                           (find (aref string (1- (length string))) "\\/"))))
+      (multiple-value-bind (file type)
+          (cond ((and (not directoryp) (last path))
+                 (let* ((file (car (last path)))
+                        (pos (position #\. file :from-end t)))
+                   (cond ((and pos (> pos 0)) 
+                          (values (subseq file 0 pos)
+                                  (subseq file (1+ pos))))
+                         (t file)))))
+        (make-pathname :host nil
+                       :device nil
+                       :directory (cons 
+                                   (if absolute :absolute :relative)
+                                   (let ((path (if directoryp 
+                                                   path 
+                                                   (butlast path))))
+                                     (if drive
+                                         (cons 
+                                          (regexp:match-string string drive)
+                                          path)
+                                         path)))
+                       :name file 
+                       :type type)))))
+
+;;;; UTF 
+
+(defimplementation string-to-utf8 (string)
+  (let ((enc (load-time-value 
+              (ext:make-encoding :charset "utf-8" :line-terminator :unix)
+              t)))
+    (ext:convert-string-to-bytes string enc)))
+
+(defimplementation utf8-to-string (octets)
+  (let ((enc (load-time-value 
+              (ext:make-encoding :charset "utf-8" :line-terminator :unix)
+              t)))
+    (ext:convert-string-from-bytes octets enc)))
+
+;;;; TCP Server
+
+(defimplementation create-socket (host port &key backlog)
+  (socket:socket-server port :interface host :backlog (or backlog 5)))
+
+(defimplementation local-port (socket)
+  (socket:socket-server-port socket))
+
+(defimplementation close-socket (socket)
+  (socket:socket-server-close socket))
+
+(defimplementation accept-connection (socket
+                                      &key external-format buffering timeout)
+  (declare (ignore buffering timeout))
+  (socket:socket-accept socket
+                        :buffered buffering ;; XXX may not work if t
+                        :element-type (if external-format 
+                                          'character
+                                          '(unsigned-byte 8))
+                        :external-format (or external-format :default)))
+
+#-win32
+(defimplementation wait-for-input (streams &optional timeout)
+  (assert (member timeout '(nil t)))
+  (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
+    (loop
+     (cond ((check-slime-interrupts) (return :interrupt))
+           (timeout
+            (socket:socket-status streams 0 0)
+            (return (loop for (s nil . x) in streams
+                          if x collect s)))
+           (t
+            (with-simple-restart (socket-status "Return from socket-status.")
+              (socket:socket-status streams 0 500000))
+            (let ((ready (loop for (s nil . x) in streams
+                               if x collect s)))
+              (when ready (return ready))))))))
+
+#+win32
+(defimplementation wait-for-input (streams &optional timeout)
+  (assert (member timeout '(nil t)))
+  (loop
+   (cond ((check-slime-interrupts) (return :interrupt))
+         (t
+          (let ((ready (remove-if-not #'input-available-p streams)))
+            (when ready (return ready)))
+          (when timeout (return nil))
+          (sleep 0.1)))))
+
+#+win32
+;; Some facts to remember (for the next time we need to debug this):
+;;  - interactive-sream-p returns t for socket-streams
+;;  - listen returns nil for socket-streams
+;;  - (type-of <socket-stream>) is 'stream
+;;  - (type-of *terminal-io*) is 'two-way-stream
+;;  - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8)
+;;  - calling socket:socket-status on non sockets signals an error,
+;;    but seems to mess up something internally.
+;;  - calling read-char-no-hang on sockets does not signal an error,
+;;    but seems to mess up something internally.
+(defun input-available-p (stream)
+  (case (stream-element-type stream)
+    (character
+     (let ((c (read-char-no-hang stream nil nil)))
+       (cond ((not c)
+              nil)
+             (t
+              (unread-char c stream)
+              t))))
+    (t
+     (eq (socket:socket-status (cons stream :input) 0 0)
+         :input))))
+
+;;;; Coding systems
+
+(defvar *external-format-to-coding-system*
+  '(((:charset "iso-8859-1" :line-terminator :unix)
+     "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
+    ((:charset "iso-8859-1")
+     "latin-1" "iso-latin-1" "iso-8859-1")
+    ((:charset "utf-8") "utf-8")
+    ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
+    ((:charset "euc-jp") "euc-jp")
+    ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
+    ((:charset "us-ascii") "us-ascii")
+    ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+  (let ((args (car (rassoc-if (lambda (x)
+                                (member coding-system x :test #'equal))
+                              *external-format-to-coding-system*))))
+    (and args (apply #'ext:make-encoding args))))
+
+
+;;;; Swank functions
+
+(defimplementation arglist (fname)
+  (block nil
+    (or (ignore-errors
+          (let ((exp (function-lambda-expression fname)))
+            (and exp (return (second exp)))))
+        (ignore-errors
+          (return (ext:arglist fname)))
+        :not-available)))
+
+(defimplementation macroexpand-all (form &optional env)
+  (declare (ignore env))
+  (ext:expand-form form))
+
+(defimplementation collect-macro-forms (form &optional env)
+  ;; Currently detects only normal macros, not compiler macros.
+  (declare (ignore env))
+  (with-collected-macro-forms (macro-forms)
+      (handler-bind ((warning #'muffle-warning))
+        (ignore-errors
+          (compile nil `(lambda () ,form))))
+    (values macro-forms nil)))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+  "Return a plist describing SYMBOL.
+Return NIL if the symbol is unbound."
+  (let ((result ()))
+    (flet ((doc (kind)
+             (or (documentation symbol kind) :not-documented))
+           (maybe-push (property value)
+             (when value
+               (setf result (list* property value result)))))
+      (maybe-push :variable (when (boundp symbol) (doc 'variable)))
+      (when (fboundp symbol)
+        (maybe-push
+         ;; Report WHEN etc. as macros, even though they may be
+         ;; implemented as special operators.
+         (if (macro-function symbol) :macro
+             (typecase (fdefinition symbol)
+               (generic-function :generic-function)
+               (function         :function)
+               ;; (type-of 'progn) -> ext:special-operator
+               (t                :special-operator)))
+         (doc 'function)))
+      (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
+                (get symbol 'system::setf-expander)); defsetf
+        (maybe-push :setf (doc 'setf)))
+      (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
+                (get symbol 'system::defstruct-description)
+                (get symbol 'system::deftype-expander))
+        (maybe-push :type (doc 'type))) ; even for 'structure
+      (when (find-class symbol nil)
+        (maybe-push :class (doc 'type)))
+      ;; Let this code work compiled in images without FFI
+      (let ((types (load-time-value
+                    (and (find-package "FFI")
+                         (symbol-value
+                          (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
+        ;; Use ffi::*c-type-table* so as not to suffer the overhead of
+        ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
+        ;; which are not FFI type names.
+        (when (and types (nth-value 1 (gethash symbol types)))
+          ;; Maybe use (case (head (ffi:deparse-c-type)))
+          ;; to distinguish struct and union types?
+          (maybe-push :alien-type :not-documented)))
+      result)))
+
+(defimplementation describe-definition (symbol namespace)
+  (ecase namespace
+    (:variable (describe symbol))
+    (:macro (describe (macro-function symbol)))
+    (:function (describe (symbol-function symbol)))
+    (:class (describe (find-class symbol)))))
+
+(defimplementation type-specifier-p (symbol)
+  (or (ignore-errors
+       (subtypep nil symbol))
+      (not (eq (type-specifier-arglist symbol) :not-available))))
+
+(defun fspec-pathname (spec)
+  (let ((path spec)
+	type
+        lines)
+    (when (consp path)
+      (psetq type (car path)
+	     path (cadr path)
+             lines (cddr path)))
+    (when (and path
+               (member (pathname-type path)
+                       custom:*compiled-file-types* :test #'equal))
+      (setq path
+            (loop for suffix in custom:*source-file-types*
+               thereis (probe-file (make-pathname :defaults path
+                                                  :type suffix)))))
+    (values path type lines)))
+
+(defun fspec-location (name fspec)
+  (multiple-value-bind (file type lines)
+      (fspec-pathname fspec)
+    (list (if type (list name type) name)
+	  (cond (file
+		 (multiple-value-bind (truename c) 
+                     (ignore-errors (truename file))
+		   (cond (truename
+			  (make-location 
+                           (list :file (namestring truename))
+                           (if (consp lines)
+                               (list* :line lines)
+                               (list :function-name (string name)))
+                           (when (consp type)
+                             (list :snippet (format nil "~A" type)))))
+			 (t (list :error (princ-to-string c))))))
+		(t (list :error 
+                         (format nil "No source information available for: ~S"
+                                 fspec)))))))
+
+(defimplementation find-definitions (name)
+  (mapcar #'(lambda (e) (fspec-location name e)) 
+          (documentation name 'sys::file)))
+
+(defun trim-whitespace (string)
+  (string-trim #(#\newline #\space #\tab) string))
+
+(defvar *sldb-backtrace*)
+
+(defun sldb-backtrace ()
+  "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
+  (let* ((modes '((:all-stack-elements 1)
+                  (:all-frames 2)
+                  (:only-lexical-frames 3)
+                  (:only-eval-and-apply-frames 4)
+                  (:only-apply-frames 5)))
+         (mode (cadr (assoc :all-stack-elements modes))))
+    (do ((frames '())
+         (last nil frame)
+         (frame (sys::the-frame)
+                (sys::frame-up 1 frame mode)))
+        ((eq frame last) (nreverse frames))
+      (unless (boring-frame-p frame)
+        (push frame frames)))))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+  (let* (;;(sys::*break-count* (1+ sys::*break-count*))
+         ;;(sys::*driver* debugger-loop-fn)
+         ;;(sys::*fasoutput-stream* nil)
+         (*sldb-backtrace*
+          (let* ((f (sys::the-frame))
+                 (bt (sldb-backtrace))
+                 (rest (member f bt)))
+            (if rest (nthcdr 8 rest) bt))))
+    (funcall debugger-loop-fn)))
+
+(defun nth-frame (index)
+  (nth index *sldb-backtrace*))
+
+(defun boring-frame-p (frame)
+  (member (frame-type frame) '(stack-value bind-var bind-env
+                               compiled-tagbody compiled-block)))
+
+(defun frame-to-string (frame)
+  (with-output-to-string (s)
+    (sys::describe-frame s frame)))
+
+(defun frame-type (frame)
+  ;; FIXME: should bind *print-length* etc. to small values.
+  (frame-string-type (frame-to-string frame)))
+
+;; FIXME: they changed the layout in 2.44 and not all patterns have
+;; been updated.
+(defvar *frame-prefixes*
+  '(("\\[[0-9]\\+\\] frame binding variables" bind-var)
+    ("<1> #<compiled-function" compiled-fun)
+    ("<1> #<system-function" sys-fun)
+    ("<1> #<special-operator" special-op)
+    ("EVAL frame" eval)
+    ("APPLY frame" apply)
+    ("\\[[0-9]\\+\\] compiled tagbody frame" compiled-tagbody)
+    ("\\[[0-9]\\+\\] compiled block frame" compiled-block)
+    ("block frame" block)
+    ("nested block frame" block)
+    ("tagbody frame" tagbody)
+    ("nested tagbody frame" tagbody)
+    ("catch frame" catch)
+    ("handler frame" handler)
+    ("unwind-protect frame" unwind-protect)
+    ("driver frame" driver)
+    ("\\[[0-9]\\+\\] frame binding environments" bind-env)
+    ("CALLBACK frame" callback)
+    ("- " stack-value)
+    ("<1> " fun)
+    ("<2> " 2nd-frame)
+    ))
+
+(defun frame-string-type (string)
+  (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
+                  *frame-prefixes*)))
+
+(defimplementation compute-backtrace (start end)
+  (let* ((bt *sldb-backtrace*)
+         (len (length bt)))
+    (loop for f in (subseq bt start (min (or end len) len))
+          collect f)))
+
+(defimplementation print-frame (frame stream)
+  (let* ((str (frame-to-string frame)))
+    (write-string (extract-frame-line str)
+                  stream)))
+
+(defun extract-frame-line (frame-string)
+  (let ((s frame-string))
+    (trim-whitespace
+     (case (frame-string-type s)
+       ((eval special-op)
+        (string-match "EVAL frame .*for form \\(.*\\)" s 1))
+       (apply
+        (string-match "APPLY frame for call \\(.*\\)" s 1))
+       ((compiled-fun sys-fun fun)
+        (extract-function-name s))
+       (t s)))))
+
+(defun extract-function-name (string)
+  (let ((1st (car (split-frame-string string))))
+    (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
+                      1st
+                      1)
+        (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
+        1st)))
+
+(defun split-frame-string (string)
+  (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
+                    (mapcar #'car *frame-prefixes*))))
+    (loop for pos = 0 then (1+ (regexp:match-start match))
+          for match = (regexp:match rx string :start pos)
+          if match collect (subseq string pos (regexp:match-start match))
+          else collect (subseq string pos)
+          while match)))
+
+(defun string-match (pattern string n)
+  (let* ((match (nth-value n (regexp:match pattern string))))
+    (if match (regexp:match-string string match))))
+
+(defimplementation eval-in-frame (form frame-number)
+  (sys::eval-at (nth-frame frame-number) form))
+
+(defimplementation frame-locals (frame-number)
+  (let ((frame (nth-frame frame-number)))
+    (loop for i below (%frame-count-vars frame)
+          collect (list :name (%frame-var-name frame i)
+                        :value (%frame-var-value frame i)
+                        :id 0))))
+
+(defimplementation frame-var-value (frame var)
+  (%frame-var-value (nth-frame frame) var))
+
+;;; Interpreter-Variablen-Environment has the shape
+;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
+
+(defun %frame-count-vars (frame)
+  (cond ((sys::eval-frame-p frame)
+         (do ((venv (frame-venv frame) (next-venv venv))
+              (count 0 (+ count (/ (1- (length venv)) 2))))
+             ((not venv) count)))
+        ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
+         (length (%parse-stack-values frame)))
+        (t 0)))
+
+(defun %frame-var-name (frame i)
+  (cond ((sys::eval-frame-p frame)
+         (nth-value 0 (venv-ref (frame-venv frame) i)))
+        (t (format nil "~D" i))))
+
+(defun %frame-var-value (frame i)
+  (cond ((sys::eval-frame-p frame)
+         (let ((name (venv-ref (frame-venv frame) i)))
+           (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
+             (if c
+                 (format-sldb-condition c)
+                 v))))
+        ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
+         (let ((str (nth i (%parse-stack-values frame))))
+           (trim-whitespace (subseq str 2))))
+        (t (break "Not implemented"))))
+
+(defun frame-venv (frame)
+  (let ((env (sys::eval-at frame '(sys::the-environment))))
+    (svref env 0)))
+
+(defun next-venv (venv) (svref venv (1- (length venv))))
+
+(defun venv-ref (env i)
+  "Reference the Ith binding in ENV.
+Return two values: NAME and VALUE"
+  (let ((idx (* i 2)))
+    (if (< idx (1- (length env)))
+        (values (svref env idx) (svref env (1+ idx)))
+        (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
+
+(defun %parse-stack-values (frame)
+  (labels ((next (fp) (sys::frame-down 1 fp 1))
+           (parse (fp accu)
+             (let ((str (frame-to-string fp)))
+               (cond ((is-prefix-p "- " str)
+                      (parse  (next fp) (cons str accu)))
+                     ((is-prefix-p "<1> " str)
+                      ;;(when (eq (frame-type frame) 'compiled-fun)
+                      ;;  (pop accu))
+                      (dolist (str (cdr (split-frame-string str)))
+                        (when (is-prefix-p "- " str)
+                          (push str accu)))
+                      (nreverse accu))
+                     (t (parse (next fp) accu))))))
+    (parse (next frame) '())))
+
+(defun is-prefix-p (regexp string)
+  (if (regexp:match (concatenate 'string "^" regexp) string) t))
+
+(defimplementation return-from-frame (index form)
+  (sys::return-from-eval-frame (nth-frame index) form))
+
+(defimplementation restart-frame (index)
+  (sys::redo-eval-frame (nth-frame index)))
+
+(defimplementation frame-source-location (index)
+  `(:error
+    ,(format nil "frame-source-location not implemented. (frame: ~A)"
+             (nth-frame index))))
+
+;;;; Profiling
+
+(defimplementation profile (fname)
+  (eval `(swank-monitor:monitor ,fname)))         ;monitor is a macro
+
+(defimplementation profiled-functions ()
+  swank-monitor:*monitored-functions*)
+
+(defimplementation unprofile (fname)
+  (eval `(swank-monitor:unmonitor ,fname)))       ;unmonitor is a macro
+
+(defimplementation unprofile-all ()
+  (swank-monitor:unmonitor))
+
+(defimplementation profile-report ()
+  (swank-monitor:report-monitoring))
+
+(defimplementation profile-reset ()
+  (swank-monitor:reset-all-monitoring))
+
+(defimplementation profile-package (package callers-p methods)
+  (declare (ignore callers-p methods))
+  (swank-monitor:monitor-all package))
+
+;;;; Handle compiler conditions (find out location of error etc.)
+
+(defmacro compile-file-frobbing-notes ((&rest args) &body body)
+  "Pass ARGS to COMPILE-FILE, send the compiler notes to
+*STANDARD-INPUT* and frob them in BODY."
+  `(let ((*error-output* (make-string-output-stream))
+         (*compile-verbose* t))
+     (multiple-value-prog1
+      (compile-file ,@args)
+      (handler-case
+       (with-input-from-string
+        (*standard-input* (get-output-stream-string *error-output*))
+        ,@body)
+       (sys::simple-end-of-file () nil)))))
+
+(defvar *orig-c-warn* (symbol-function 'system::c-warn))
+(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
+(defvar *orig-c-error* (symbol-function 'system::c-error))
+(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
+
+(defmacro dynamic-flet (names-functions &body body)
+  "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
+Execute BODY with NAME's function slot set to FUNCTION."
+  `(ext:letf* ,(loop for (name function) in names-functions
+                     collect `((symbol-function ',name) ,function))
+    ,@body))
+
+(defvar *buffer-name* nil)
+(defvar *buffer-offset*)
+
+(defun compiler-note-location ()
+  "Return the current compiler location."
+  (let ((lineno1 sys::*compile-file-lineno1*)
+        (lineno2 sys::*compile-file-lineno2*)
+        (file sys::*compile-file-truename*))
+    (cond ((and file lineno1 lineno2)
+           (make-location (list ':file (namestring file))
+                          (list ':line lineno1)))
+          (*buffer-name*
+           (make-location (list ':buffer *buffer-name*)
+                          (list ':offset *buffer-offset* 0)))
+          (t
+           (list :error "No error location available")))))
+
+(defun signal-compiler-warning (cstring args severity orig-fn)
+  (signal 'compiler-condition
+          :severity severity
+          :message (apply #'format nil cstring args)
+          :location (compiler-note-location))
+  (apply orig-fn cstring args))
+
+(defun c-warn (cstring &rest args)
+  (signal-compiler-warning cstring args :warning *orig-c-warn*))
+
+(defun c-style-warn (cstring &rest args)
+  (dynamic-flet ((sys::c-warn *orig-c-warn*))
+    (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
+
+(defun c-error (&rest args)
+  (signal 'compiler-condition
+          :severity :error
+          :message (apply #'format nil
+                          (if (= (length args) 3)
+                              (cdr args)
+                              args))
+          :location (compiler-note-location))
+  (apply *orig-c-error* args))
+
+(defimplementation call-with-compilation-hooks (function)
+  (handler-bind ((warning #'handle-notification-condition))
+    (dynamic-flet ((system::c-warn #'c-warn)
+                   (system::c-style-warn #'c-style-warn)
+                   (system::c-error #'c-error))
+      (funcall function))))
+
+(defun handle-notification-condition (condition)
+  "Handle a condition caused by a compiler warning."
+  (signal 'compiler-condition
+          :original-condition condition
+          :severity :warning
+          :message (princ-to-string condition)
+          :location (compiler-note-location)))
+
+(defimplementation swank-compile-file (input-file output-file
+                                       load-p external-format
+                                       &key policy)
+  (declare (ignore policy))
+  (with-compilation-hooks ()
+    (with-compilation-unit ()
+      (multiple-value-bind (fasl-file warningsp failurep)
+          (compile-file input-file 
+                        :output-file output-file
+                        :external-format external-format)
+        (values fasl-file warningsp
+                (or failurep 
+                    (and load-p 
+                         (not (load fasl-file)))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+                                                line column policy)
+  (declare (ignore filename line column policy))
+  (with-compilation-hooks ()
+    (let ((*buffer-name* buffer)
+          (*buffer-offset* position))
+      (funcall (compile nil (read-from-string
+                             (format nil "(~S () ~A)" 'lambda string))))
+      t)))
+
+;;;; Portable XREF from the CMU AI repository.
+
+(setq pxref::*handle-package-forms* '(cl:in-package))
+
+(defmacro defxref (name function)
+  `(defimplementation ,name (name)
+    (xref-results (,function name))))
+
+(defxref who-calls      pxref:list-callers)
+(defxref who-references pxref:list-readers)
+(defxref who-binds      pxref:list-setters)
+(defxref who-sets       pxref:list-setters)
+(defxref list-callers   pxref:list-callers)
+(defxref list-callees   pxref:list-callees)
+
+(defun xref-results (symbols)
+  (let ((xrefs '()))
+    (dolist (symbol symbols)
+      (push (fspec-location symbol symbol) xrefs))
+    xrefs))
+
+(when (find-package :swank-loader)
+  (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
+        (lambda ()
+          (let ((home (user-homedir-pathname)))
+            (and (ext:probe-directory home)
+                 (probe-file (format nil "~A/.swank.lisp"
+                                     (namestring (truename home)))))))))
+
+;;; Don't set *debugger-hook* to nil on break.
+(ext:without-package-lock ()
+ (defun break (&optional (format-string "Break") &rest args)
+   (if (not sys::*use-clcs*)
+       (progn
+         (terpri *error-output*)
+         (apply #'format *error-output*
+                (concatenate 'string "*** - " format-string)
+                args)
+         (funcall ext:*break-driver* t))
+       (let ((condition
+              (make-condition 'simple-condition
+                              :format-control format-string
+                              :format-arguments args))
+             ;;(*debugger-hook* nil)
+             ;; Issue 91
+             )
+         (ext:with-restarts
+             ((continue
+               :report (lambda (stream)
+                         (format stream (sys::text "Return from ~S loop")
+                                 'break))
+               ()))
+           (with-condition-restarts condition (list (find-restart 'continue))
+                                    (invoke-debugger condition)))))
+   nil))
+
+;;;; Inspecting
+
+(defmethod emacs-inspect ((o t))
+  (let* ((*print-array* nil) (*print-pretty* t)
+         (*print-circle* t) (*print-escape* t)
+         (*print-lines* custom:*inspect-print-lines*)
+         (*print-level* custom:*inspect-print-level*)
+         (*print-length* custom:*inspect-print-length*)
+         (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
+         (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
+         (*package* tmp-pack)
+         (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
+    (let ((inspection (sys::inspect-backend o)))
+      (append (list
+               (format nil "~S~% ~A~{~%~A~}~%" o
+                      (sys::insp-title inspection)
+                      (sys::insp-blurb inspection)))
+              (loop with count = (sys::insp-num-slots inspection)
+                    for i below count
+                    append (multiple-value-bind (value name)
+                               (funcall (sys::insp-nth-slot inspection)
+                                        i)
+                             `((:value ,name) " = " (:value ,value)
+                               (:newline))))))))
+
+(defimplementation quit-lisp ()
+  #+lisp=cl (ext:quit)
+  #-lisp=cl (lisp:quit))
+
+
+(defimplementation preferred-communication-style ()
+  nil)
+
+;;; FIXME
+;;;
+;;; Clisp 2.48 added experimental support for threads. Basically, you
+;;; can use :SPAWN now, BUT:
+;;; 
+;;;   - there are problems with GC, and threads stuffed into weak
+;;;     hash-tables as is the case for *THREAD-PLIST-TABLE*.
+;;;
+;;;     See test case at
+;;;       http://thread.gmane.org/gmane.lisp.clisp.devel/20429
+;;;
+;;;     Even though said to be fixed, it's not:
+;;;
+;;;       http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443
+;;;
+;;;   - The DYNAMIC-FLET above is an implementation technique that's
+;;;     probably not sustainable in light of threads. This got to be
+;;;     rewritten.
+;;;
+;;; TCR (2009-07-30)
+
+#+#.(cl:if (cl:find-package "MP") '(:and) '(:or)) 
+(progn
+  (defimplementation spawn (fn &key name)
+    (mp:make-thread fn :name name))
+
+  (defvar *thread-plist-table-lock*
+    (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK"))
+
+  (defvar *thread-plist-table* (make-hash-table :weak :key)
+    "A hashtable mapping threads to a plist.")
+
+  (defvar *thread-id-counter* 0)
+
+  (defimplementation thread-id (thread)
+    (mp:with-mutex-lock (*thread-plist-table-lock*)
+      (or (getf (gethash thread *thread-plist-table*) 'thread-id)
+          (setf (getf (gethash thread *thread-plist-table*) 'thread-id)
+                (incf *thread-id-counter*)))))
+
+  (defimplementation find-thread (id)
+    (find id (all-threads)
+          :key (lambda (thread)
+                 (getf (gethash thread *thread-plist-table*) 'thread-id))))
+
+  (defimplementation thread-name (thread)
+    ;; To guard against returning #<UNBOUND>.
+    (princ-to-string (mp:thread-name thread)))
+
+  (defimplementation thread-status (thread)
+    (if (thread-alive-p thread)
+        "RUNNING"
+        "STOPPED"))
+
+  (defimplementation make-lock (&key name)
+    (mp:make-mutex :name name :recursive-p t))
+
+  (defimplementation call-with-lock-held (lock function)
+    (mp:with-mutex-lock (lock)
+      (funcall function)))
+
+  (defimplementation current-thread ()
+    (mp:current-thread))
+
+  (defimplementation all-threads ()
+    (mp:list-threads))
+
+  (defimplementation interrupt-thread (thread fn)
+    (mp:thread-interrupt thread :function fn))
+
+  (defimplementation kill-thread (thread)
+    (mp:thread-interrupt thread :function t))
+
+  (defimplementation thread-alive-p (thread)
+    (mp:thread-active-p thread))
+
+  (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK"))
+  (defvar *mailboxes* (list))
+
+  (defstruct (mailbox (:conc-name mailbox.))
+    thread
+    (lock (make-lock :name "MAILBOX.LOCK"))
+    (waitqueue  (mp:make-exemption :name "MAILBOX.WAITQUEUE"))
+    (queue '() :type list))
+
+  (defun mailbox (thread)
+    "Return THREAD's mailbox."
+    (mp:with-mutex-lock (*mailboxes-lock*)
+      (or (find thread *mailboxes* :key #'mailbox.thread)
+          (let ((mb (make-mailbox :thread thread)))
+            (push mb *mailboxes*)
+            mb))))
+
+  (defimplementation send (thread message)
+    (let* ((mbox (mailbox thread))
+           (lock (mailbox.lock mbox)))
+      (mp:with-mutex-lock (lock)
+        (setf (mailbox.queue mbox)
+              (nconc (mailbox.queue mbox) (list message)))
+        (mp:exemption-broadcast (mailbox.waitqueue mbox)))))
+
+  (defimplementation receive-if (test &optional timeout)
+    (let* ((mbox (mailbox (current-thread)))
+           (lock (mailbox.lock mbox)))
+      (assert (or (not timeout) (eq timeout t)))
+      (loop
+       (check-slime-interrupts)
+       (mp:with-mutex-lock (lock)
+         (let* ((q (mailbox.queue mbox))
+                (tail (member-if test q)))
+           (when tail 
+             (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
+             (return (car tail))))
+         (when (eq timeout t) (return (values nil t)))
+         (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2))))))
+ 
+
+;;;; Weak hashtables
+
+(defimplementation make-weak-key-hash-table (&rest args)
+  (apply #'make-hash-table :weak :key args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+  (apply #'make-hash-table :weak :value args))
+
+(defimplementation save-image (filename &optional restart-function)
+  (let ((args `(,filename 
+                ,@(if restart-function 
+                      `((:init-function ,restart-function))))))
+    (apply #'ext:saveinitmem args)))

sources_non_forked/slimv/slime/swank/corman.lisp

@@ -0,0 +1,583 @@
+;;;
+;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
+;;;
+;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org)
+;;;
+;;; License
+;;; =======
+;;; This software is provided 'as-is', without any express or implied
+;;; warranty. In no event will the author be held liable for any damages
+;;; arising from the use of this software.
+;;;
+;;; Permission is granted to anyone to use this software for any purpose,
+;;; including commercial applications, and to alter it and redistribute
+;;; it freely, subject to the following restrictions:
+;;;
+;;; 1. The origin of this software must not be misrepresented; you must
+;;;    not claim that you wrote the original software. If you use this
+;;;    software in a product, an acknowledgment in the product documentation
+;;;    would be appreciated but is not required.
+;;;
+;;; 2. Altered source versions must be plainly marked as such, and must
+;;;    not be misrepresented as being the original software.
+;;;
+;;; 3. This notice may not be removed or altered from any source 
+;;;    distribution.
+;;;
+;;; Notes
+;;; =====
+;;; You will need CCL 2.51, and you will *definitely* need to patch
+;;; CCL with the patches at
+;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
+;;; will blow up in your face.  You should also follow the
+;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
+;;;
+;;; The only communication style currently supported is NIL.
+;;;
+;;; Starting CCL inside emacs (with M-x slime) seems to work for me
+;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
+;;; (sometimes it works, other times it hangs on start or hangs when
+;;; initializing WinSock) - starting CCL externally and using M-x
+;;; slime-connect always works fine.
+;;;
+;;; Sometimes CCL gets confused and starts giving you random memory
+;;; access violation errors on startup; if this happens, try redumping
+;;; your image.
+;;;
+;;; What works
+;;; ==========
+;;; * Basic editing and evaluation
+;;; * Arglist display
+;;; * Compilation
+;;; * Loading files
+;;; * apropos/describe
+;;; * Debugger
+;;; * Inspector
+;;; 
+;;; TODO
+;;; ====
+;;; * More debugger functionality (missing bits: restart-frame,
+;;; return-from-frame, disassemble-frame, activate-stepping,
+;;; toggle-trace)
+;;; * XREF
+;;; * Profiling
+;;; * More sophisticated communication styles than NIL
+;;;
+
+(in-package :swank/backend)
+
+;;; Pull in various needed bits
+(require :composite-streams)
+(require :sockets)
+(require :winbase)
+(require :lp)
+
+(use-package :gs)
+
+;; MOP stuff
+
+(defclass swank-mop:standard-slot-definition ()
+  ()
+  (:documentation 
+   "Dummy class created so that swank.lisp will compile and load."))
+
+(defun named-by-gensym-p (c)
+  (null (symbol-package (class-name c))))
+
+(deftype swank-mop:eql-specializer ()
+  '(satisfies named-by-gensym-p))
+
+(defun swank-mop:eql-specializer-object (specializer)
+  (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
+    (loop (multiple-value-bind (more key value)
+              (next-entry)
+            (unless more (return nil))
+            (when (eq specializer value)
+              (return key))))))
+
+(defun swank-mop:class-finalized-p (class)
+  (declare (ignore class))
+  t)
+
+(defun swank-mop:class-prototype (class)
+  (make-instance class))
+
+(defun swank-mop:specializer-direct-methods (obj)
+  (declare (ignore obj))
+  nil)
+
+(defun swank-mop:generic-function-argument-precedence-order (gf)
+  (generic-function-lambda-list gf))
+
+(defun swank-mop:generic-function-method-combination (gf)
+  (declare (ignore gf))
+  :standard)
+
+(defun swank-mop:generic-function-declarations (gf)
+  (declare (ignore gf))
+  nil)
+
+(defun swank-mop:slot-definition-documentation (slot)
+  (declare (ignore slot))
+  (getf slot :documentation nil))
+
+(defun swank-mop:slot-definition-type (slot)
+  (declare (ignore slot))
+  t)
+
+(import-swank-mop-symbols :cl '(;; classes
+                                :standard-slot-definition
+                                :eql-specializer
+                                :eql-specializer-object
+                                ;; standard class readers
+                                :class-default-initargs
+                                :class-direct-default-initargs
+                                :class-finalized-p
+                                :class-prototype
+                                :specializer-direct-methods
+                                ;; gf readers
+                                :generic-function-argument-precedence-order
+                                :generic-function-declarations
+                                :generic-function-method-combination
+                                ;; method readers
+                                ;; slot readers
+                                :slot-definition-documentation
+                                :slot-definition-type))
+
+;;;; swank implementations
+
+;;; Debugger
+
+(defvar *stack-trace* nil)
+(defvar *frame-trace* nil)
+
+(defstruct frame
+  name function address debug-info variables)
+
+(defimplementation call-with-debugging-environment (fn)
+  (let* ((real-stack-trace (cl::stack-trace))
+         (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
+                                     :key #'car)))
+         (*frame-trace*
+          (let* ((db::*debug-level*         (1+ db::*debug-level*))
+                 (db::*debug-frame-pointer* (db::stash-ebp
+                                             (ct:create-foreign-ptr)))
+                 (db::*debug-max-level*     (length real-stack-trace))
+                 (db::*debug-min-level*     1))
+            (cdr (member #'cl:invoke-debugger
+                         (cons
+                          (make-frame :function nil)
+                          (loop for i from db::*debug-min-level*
+                             upto db::*debug-max-level*
+                             until (eq (db::get-frame-function i) 
+				       cl::*top-level*)
+                             collect
+                               (make-frame 
+				:function (db::get-frame-function i)
+				:address (db::get-frame-address i))))
+                         :key #'frame-function)))))
+    (funcall fn)))
+
+(defimplementation compute-backtrace (start end)
+  (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
+	collect f))
+
+(defimplementation print-frame (frame stream)
+  (format stream "~S" frame))
+
+(defun get-frame-debug-info (frame)
+  (or (frame-debug-info frame)
+      (setf (frame-debug-info frame)
+	    (db::prepare-frame-debug-info (frame-function frame)
+					  (frame-address frame)))))
+
+(defimplementation frame-locals (frame-number)
+  (let* ((frame (elt *frame-trace* frame-number))
+         (info (get-frame-debug-info frame)))
+    (let ((var-list
+           (loop for i from 4 below (length info) by 2
+              collect `(list :name ',(svref info i) :id 0
+                             :value (db::debug-filter ,(svref info i))))))
+      (let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
+        (setf (frame-variables frame) vars)))))
+
+(defimplementation eval-in-frame (form frame-number)
+  (let ((frame (elt *frame-trace* frame-number)))
+    (let ((cl::*compiler-environment* (get-frame-debug-info frame)))
+      (eval form))))
+
+(defimplementation frame-var-value (frame-number var)
+  (let ((vars (frame-variables (elt *frame-trace* frame-number))))
+    (when vars
+      (second (elt vars var)))))
+
+(defimplementation frame-source-location (frame-number)
+  (fspec-location (frame-function (elt *frame-trace* frame-number))))
+
+(defun break (&optional (format-control "Break") &rest format-arguments)
+  (with-simple-restart (continue "Return from BREAK.")
+    (let ();(*debugger-hook* nil))
+      (let ((condition 
+	     (make-condition 'simple-condition
+			     :format-control format-control
+			     :format-arguments format-arguments)))
+	;;(format *debug-io* ";;; User break: ~A~%" condition)
+	(invoke-debugger condition))))
+  nil)
+
+;;; Socket communication
+
+(defimplementation create-socket (host port &key backlog)
+  (sockets:start-sockets)
+  (sockets:make-server-socket :host host :port port))
+
+(defimplementation local-port (socket)
+  (sockets:socket-port socket))
+
+(defimplementation close-socket (socket)
+  (close socket))
+
+(defimplementation accept-connection (socket
+				      &key external-format buffering timeout)
+  (declare (ignore buffering timeout external-format))
+  (sockets:make-socket-stream (sockets:accept-socket socket)))
+
+;;; Misc
+
+(defimplementation preferred-communication-style ()
+  nil)
+
+(defimplementation getpid ()
+  ccl:*current-process-id*)
+
+(defimplementation lisp-implementation-type-name ()
+  "cormanlisp")
+
+(defimplementation quit-lisp ()
+  (sockets:stop-sockets)
+  (win32:exitprocess 0))
+
+(defimplementation set-default-directory (directory)
+  (setf (ccl:current-directory) directory)
+  (directory-namestring (setf *default-pathname-defaults* 
+                              (truename (merge-pathnames directory)))))
+
+(defimplementation default-directory ()
+  (directory-namestring (ccl:current-directory)))
+
+(defimplementation macroexpand-all (form &optional env)
+  (declare (ignore env))
+  (ccl:macroexpand-all form))
+
+;;; Documentation
+
+(defun fspec-location (fspec)
+  (when (symbolp fspec)
+    (setq fspec (symbol-function fspec)))
+  (let ((file (ccl::function-source-file fspec)))
+    (if file
+        (handler-case
+            (let ((truename (truename
+                             (merge-pathnames file
+                                              ccl:*cormanlisp-directory*))))
+              (make-location (list :file (namestring truename))
+                             (if (ccl::function-source-line fspec)
+                                 (list :line 
+				       (1+ (ccl::function-source-line fspec)))
+                                 (list :function-name 
+				       (princ-to-string
+					(function-name fspec))))))
+          (error (c) (list :error (princ-to-string c))))
+        (list :error (format nil "No source information available for ~S"
+                             fspec)))))
+
+(defimplementation find-definitions (name)
+  (list (list name (fspec-location name))))
+
+(defimplementation arglist (name)
+  (handler-case
+      (cond ((and (symbolp name)
+                  (macro-function name))
+             (ccl::macro-lambda-list (symbol-function name)))
+            (t
+             (when (symbolp name)
+               (setq name (symbol-function name)))
+             (if (eq (class-of name) cl::the-class-standard-gf)
+                 (generic-function-lambda-list name)
+                 (ccl:function-lambda-list name))))
+    (error () :not-available)))
+
+(defimplementation function-name (fn)
+  (handler-case (getf (cl::function-info-list fn) 'cl::function-name)
+    (error () nil)))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+  (let ((result '()))
+    (flet ((doc (kind &optional (sym symbol))
+             (or (documentation sym kind) :not-documented))
+           (maybe-push (property value)
+             (when value
+               (setf result (list* property value result)))))
+      (maybe-push
+       :variable (when (boundp symbol)
+                   (doc 'variable)))
+      (maybe-push
+       :function (if (fboundp symbol)
+                     (doc 'function)))
+      (maybe-push
+       :class (if (find-class symbol nil)
+                  (doc 'class)))
+      result)))
+
+(defimplementation describe-definition (symbol namespace)
+  (ecase namespace
+    (:variable 
+     (describe symbol))
+    ((:function :generic-function)
+     (describe (symbol-function symbol)))
+    (:class
+     (describe (find-class symbol)))))
+
+;;; Compiler 
+
+(defvar *buffer-name* nil)
+(defvar *buffer-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename* nil)
+
+;; FIXME
+(defimplementation call-with-compilation-hooks (FN)
+  (handler-bind ((error (lambda (c)
+                          (signal 'compiler-condition
+                                  :original-condition c
+                                  :severity :warning
+                                  :message (format nil "~A" c)
+                                  :location
+                                  (cond (*buffer-name*
+                                         (make-location
+                                          (list :buffer *buffer-name*)
+                                          (list :offset *buffer-position* 0)))
+                                        (*compile-filename*
+                                         (make-location
+                                          (list :file *compile-filename*)
+                                          (list :position 1)))
+                                        (t
+                                         (list :error "No location")))))))
+    (funcall fn)))
+
+(defimplementation swank-compile-file (input-file output-file 
+				       load-p external-format
+                                       &key policy)
+  (declare (ignore external-format policy))
+  (with-compilation-hooks ()
+    (let ((*buffer-name* nil)
+	  (*compile-filename* input-file))
+      (multiple-value-bind (output-file warnings? failure?)
+	  (compile-file input-file :output-file output-file)
+	(values output-file warnings?
+		(or failure? (and load-p (load output-file))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+                                                line column policy)
+  (declare (ignore filename line column policy))
+  (with-compilation-hooks ()
+    (let ((*buffer-name* buffer)
+          (*buffer-position* position)
+          (*buffer-string* string))
+      (funcall (compile nil (read-from-string
+                             (format nil "(~S () ~A)" 'lambda string))))
+      t)))
+
+;;;; Inspecting
+
+;; Hack to make swank.lisp load, at least
+(defclass file-stream ())
+
+(defun comma-separated (list &optional (callback (lambda (v)
+                                                   `(:value ,v))))
+  (butlast (loop for e in list
+              collect (funcall callback e)
+              collect ", ")))
+
+(defmethod emacs-inspect ((class standard-class))
+  `("Name: " 
+    (:value ,(class-name class))
+    (:newline)
+    "Super classes: "
+    ,@(comma-separated (swank-mop:class-direct-superclasses class))
+    (:newline)
+    "Direct Slots: "
+    ,@(comma-separated
+       (swank-mop:class-direct-slots class)
+       (lambda (slot)
+	 `(:value ,slot 
+		  ,(princ-to-string 
+		    (swank-mop:slot-definition-name slot)))))
+    (:newline)
+    "Effective Slots: "
+    ,@(if (swank-mop:class-finalized-p class)
+	  (comma-separated
+	   (swank-mop:class-slots class)
+	   (lambda (slot)
+	     `(:value ,slot ,(princ-to-string
+			      (swank-mop:slot-definition-name slot)))))
+	  '("#<N/A (class not finalized)>"))
+    (:newline)
+    ,@(when (documentation class t)
+	    `("Documentation:" (:newline) ,(documentation class t) (:newline)))
+    "Sub classes: "
+    ,@(comma-separated (swank-mop:class-direct-subclasses class)
+		       (lambda (sub)
+			 `(:value ,sub ,(princ-to-string (class-name sub)))))
+    (:newline)
+    "Precedence List: "
+    ,@(if (swank-mop:class-finalized-p class)
+	  (comma-separated 
+	   (swank-mop:class-precedence-list class)
+	   (lambda (class)
+	     `(:value ,class 
+		      ,(princ-to-string (class-name class)))))
+	  '("#<N/A (class not finalized)>"))
+    (:newline)))
+
+(defmethod emacs-inspect ((slot cons))
+  ;; Inspects slot definitions
+  (if (eq (car slot) :name)
+      `("Name: " (:value ,(swank-mop:slot-definition-name slot))
+		 (:newline)
+		 ,@(when (swank-mop:slot-definition-documentation slot)
+			 `("Documentation:"  
+			   (:newline)
+			   (:value 
+			    ,(swank-mop:slot-definition-documentation slot))
+			   (:newline)))
+		 "Init args: " (:value 
+				,(swank-mop:slot-definition-initargs slot))
+		 (:newline)
+		 "Init form: "
+		 ,(if (swank-mop:slot-definition-initfunction slot)
+		      `(:value ,(swank-mop:slot-definition-initform slot))
+		      "#<unspecified>") (:newline)
+		      "Init function: " 
+		      (:value ,(swank-mop:slot-definition-initfunction slot))
+		      (:newline))
+      (call-next-method)))
+  
+(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
+  (list*  (if (wild-pathname-p pathname)
+              "A wild pathname."
+              "A pathname.")
+	  '(:newline)
+          (append (label-value-line*
+                   ("Namestring" (namestring pathname))
+                   ("Host"       (pathname-host pathname))
+                   ("Device"     (pathname-device pathname))
+                   ("Directory"  (pathname-directory pathname))
+                   ("Name"       (pathname-name pathname))
+                   ("Type"       (pathname-type pathname))
+                   ("Version"    (pathname-version pathname)))
+                  (unless (or (wild-pathname-p pathname)
+                              (not (probe-file pathname)))
+                    (label-value-line "Truename" (truename pathname))))))
+
+(defmethod emacs-inspect ((o t))
+  (cond ((cl::structurep o) (inspect-structure o))
+	(t (call-next-method))))
+
+(defun inspect-structure (o)
+   (let* ((template (cl::uref o 1))
+	  (num-slots (cl::struct-template-num-slots template)))
+     (cond ((symbolp template)
+	    (loop for i below num-slots
+		  append (label-value-line i (cl::uref o (+ 2 i)))))
+	   (t
+	    (loop for i below num-slots
+		  append (label-value-line (elt template (+ 6 (* i 5)))
+					   (cl::uref o (+ 2 i))))))))
+
+
+;;; Threads
+
+(require 'threads)
+
+(defstruct (mailbox (:conc-name mailbox.)) 
+  thread
+  (lock (make-instance 'threads:critical-section))
+  (queue '() :type list))
+
+(defvar *mailbox-lock* (make-instance 'threads:critical-section))
+(defvar *mailboxes* (list))
+
+(defmacro with-lock  (lock &body body)
+  `(threads:with-synchronization (threads:cs ,lock)
+    ,@body))
+
+(defimplementation spawn (fun &key name)
+  (declare (ignore name))
+  (th:create-thread 
+   (lambda ()
+     (handler-bind ((serious-condition #'invoke-debugger))
+       (unwind-protect (funcall fun)
+	 (with-lock *mailbox-lock*
+	   (setq *mailboxes* (remove cormanlisp:*current-thread-id*
+				     *mailboxes* :key #'mailbox.thread))))))))
+
+(defimplementation thread-id (thread)
+  thread)
+
+(defimplementation find-thread (thread)
+  (if (thread-alive-p thread)
+      thread))
+
+(defimplementation thread-alive-p (thread)
+  (if (threads:thread-handle thread) t nil))
+
+(defimplementation current-thread ()
+  cormanlisp:*current-thread-id*)
+
+;; XXX implement it
+(defimplementation all-threads ()
+  '())
+
+;; XXX something here is broken
+(defimplementation kill-thread (thread)
+  (threads:terminate-thread thread 'killed))
+
+(defun mailbox (thread)
+  (with-lock *mailbox-lock*
+    (or (find thread *mailboxes* :key #'mailbox.thread)
+	(let ((mb (make-mailbox :thread thread)))
+	  (push mb *mailboxes*)
+	  mb))))
+
+(defimplementation send (thread message)
+  (let ((mbox (mailbox thread)))
+    (with-lock (mailbox.lock mbox)
+      (setf (mailbox.queue mbox)
+	    (nconc (mailbox.queue mbox) (list message))))))
+
+(defimplementation receive ()
+  (let ((mbox (mailbox cormanlisp:*current-thread-id*)))
+    (loop 
+     (with-lock (mailbox.lock mbox)
+       (when (mailbox.queue mbox)
+	 (return (pop (mailbox.queue mbox)))))
+     (sleep 0.1))))
+
+
+;;; This is probably not good, but it WFM
+(in-package :common-lisp)
+
+(defvar *old-documentation* #'documentation)
+(defun documentation (thing &optional (type 'function))
+  (if (symbolp thing)
+      (funcall *old-documentation* thing type)
+      (values)))
+
+(defmethod print-object ((restart restart) stream)
+  (if (or *print-escape*
+          *print-readably*)
+      (print-unreadable-object (restart stream :type t :identity t)
+        (princ (restart-name restart) stream))
+      (when (functionp (restart-report-function restart))
+        (funcall (restart-report-function restart) stream))))

sources_non_forked/slimv/slime/swank/gray.lisp

@@ -0,0 +1,207 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; swank-gray.lisp --- Gray stream based IO redirection.
+;;;
+;;; Created 2003
+;;;
+;;; This code has been placed in the Public Domain.  All warranties
+;;; are disclaimed.
+;;;
+
+(in-package swank/backend)
+
+#.(progn
+    (defvar *gray-stream-symbols*
+    '(fundamental-character-output-stream
+      stream-write-char
+      stream-write-string
+      stream-fresh-line
+      stream-force-output
+      stream-finish-output
+
+      fundamental-character-input-stream
+      stream-read-char
+      stream-peek-char
+      stream-read-line
+      stream-listen
+      stream-unread-char
+      stream-clear-input
+      stream-line-column
+      stream-read-char-no-hang))
+    nil)
+
+(defpackage swank/gray
+  (:use cl swank/backend)
+  (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)
+  (:export . #.*gray-stream-symbols*))
+
+(in-package swank/gray)
+
+(defclass slime-output-stream (fundamental-character-output-stream)
+  ((output-fn :initarg :output-fn)
+   (buffer :initform (make-string 8000))
+   (fill-pointer :initform 0)
+   (column :initform 0)
+   (lock :initform (make-lock :name "buffer write lock"))
+   (flush-thread :initarg :flush-thread
+                 :initform nil
+                 :accessor flush-thread)
+   (flush-scheduled :initarg :flush-scheduled
+                    :initform nil
+                    :accessor flush-scheduled)))
+
+(defun maybe-schedule-flush (stream)
+  (when (and (flush-thread stream)
+             (not (flush-scheduled stream)))
+    (setf (flush-scheduled stream) t)
+    (send (flush-thread stream) t)))
+
+(defmacro with-slime-output-stream (stream &body body)
+  `(with-slots (lock output-fn buffer fill-pointer column) ,stream
+     (call-with-lock-held lock (lambda () ,@body))))
+
+(defmethod stream-write-char ((stream slime-output-stream) char)
+  (with-slime-output-stream stream
+    (setf (schar buffer fill-pointer) char)
+    (incf fill-pointer)
+    (incf column)
+    (when (char= #\newline char)
+      (setf column 0))
+    (if (= fill-pointer (length buffer))
+        (finish-output stream)
+        (maybe-schedule-flush stream)))
+  char)
+
+(defmethod stream-write-string ((stream slime-output-stream) string
+                                &optional start end)
+  (with-slime-output-stream stream
+    (let* ((start (or start 0))
+           (end (or end (length string)))
+           (len (length buffer))
+           (count (- end start))
+           (free (- len fill-pointer)))
+      (when (>= count free)
+        (stream-finish-output stream))
+      (cond ((< count len)
+             (replace buffer string :start1 fill-pointer
+                      :start2 start :end2 end)
+             (incf fill-pointer count)
+             (maybe-schedule-flush stream))
+            (t
+             (funcall output-fn (subseq string start end))))
+      (let ((last-newline (position #\newline string :from-end t
+                                    :start start :end end)))
+        (setf column (if last-newline
+                         (- end last-newline 1)
+                         (+ column count))))))
+  string)
+
+(defmethod stream-line-column ((stream slime-output-stream))
+  (with-slime-output-stream stream column))
+
+(defmethod stream-finish-output ((stream slime-output-stream))
+  (with-slime-output-stream stream
+    (unless (zerop fill-pointer)
+      (funcall output-fn (subseq buffer 0 fill-pointer))
+      (setf fill-pointer 0))
+    (setf (flush-scheduled stream) nil))
+  nil)
+
+#+(and sbcl sb-thread)
+(defmethod stream-force-output :around ((stream slime-output-stream))
+  ;; Workaround for deadlocks between the world-lock and auto-flush-thread
+  ;; buffer write lock.
+  ;;
+  ;; Another alternative would be to grab the world-lock here, but that's less
+  ;; future-proof, and could introduce other lock-ordering issues in the
+  ;; future.
+  (handler-case
+      (sb-sys:with-deadline (:seconds 0.1)
+        (call-next-method))
+    (sb-sys:deadline-timeout ()
+      nil)))
+
+(defmethod stream-force-output ((stream slime-output-stream))
+  (stream-finish-output stream))
+
+(defmethod stream-fresh-line ((stream slime-output-stream))
+  (with-slime-output-stream stream
+    (cond ((zerop column) nil)
+          (t (terpri stream) t))))
+
+(defclass slime-input-stream (fundamental-character-input-stream)
+  ((input-fn :initarg :input-fn)
+   (buffer :initform "") (index :initform 0)
+   (lock :initform (make-lock :name "buffer read lock"))))
+
+(defmethod stream-read-char ((s slime-input-stream))
+  (call-with-lock-held
+   (slot-value s 'lock)
+   (lambda ()
+     (with-slots (buffer index input-fn) s
+       (when (= index (length buffer))
+         (let ((string (funcall input-fn)))
+           (cond ((zerop (length string))
+                  (return-from stream-read-char :eof))
+                 (t
+                  (setf buffer string)
+                  (setf index 0)))))
+       (assert (plusp (length buffer)))
+       (prog1 (aref buffer index) (incf index))))))
+
+(defmethod stream-listen ((s slime-input-stream))
+  (call-with-lock-held
+   (slot-value s 'lock)
+   (lambda ()
+     (with-slots (buffer index) s
+       (< index (length buffer))))))
+
+(defmethod stream-unread-char ((s slime-input-stream) char)
+  (call-with-lock-held
+   (slot-value s 'lock)
+   (lambda ()
+     (with-slots (buffer index) s
+       (decf index)
+       (cond ((eql (aref buffer index) char)
+              (setf (aref buffer index) char))
+             (t
+              (warn "stream-unread-char: ignoring ~S (expected ~S)"
+                    char (aref buffer index)))))))
+  nil)
+
+(defmethod stream-clear-input ((s slime-input-stream))
+  (call-with-lock-held
+   (slot-value s 'lock)
+   (lambda ()
+     (with-slots (buffer index) s
+       (setf buffer ""
+             index 0))))
+  nil)
+
+(defmethod stream-line-column ((s slime-input-stream))
+  nil)
+
+(defmethod stream-read-char-no-hang ((s slime-input-stream))
+  (call-with-lock-held
+   (slot-value s 'lock)
+   (lambda ()
+     (with-slots (buffer index) s
+       (when (< index (length buffer))
+         (prog1 (aref buffer index) (incf index)))))))
+
+
+;;;
+
+(defimplementation make-auto-flush-thread (stream)
+  (if (typep stream 'slime-output-stream)
+      (setf (flush-thread stream)
+            (spawn (lambda () (auto-flush-loop stream 0.08 t))
+                   :name "auto-flush-thread"))
+      (spawn (lambda () (auto-flush-loop stream *auto-flush-interval*))
+             :name "auto-flush-thread")))
+
+(defimplementation make-output-stream (write-string)
+  (make-instance 'slime-output-stream :output-fn write-string))
+
+(defimplementation make-input-stream (read-string)
+  (make-instance 'slime-input-stream :input-fn read-string))

sources_non_forked/slimv/slime/swank/match.lisp

@@ -0,0 +1,242 @@
+;;
+;;  SELECT-MATCH macro (and IN macro)
+;;
+;; Copyright 1990   Stephen Adams
+;;
+;; You are free to copy, distribute and make derivative works of this
+;; source provided that this copyright notice is displayed near the
+;; beginning of the file.  No liability is accepted for the
+;; correctness or performance of the code.  If you modify the code
+;; please indicate this fact both at the place of modification and in
+;; this copyright message.
+;;
+;;   Stephen Adams
+;;   Department of Electronics and Computer Science
+;;   University of Southampton
+;;   SO9 5NH, UK
+;;
+;; sra@ecs.soton.ac.uk
+;;
+
+;;
+;;  Synopsis:
+;;
+;;  (select-match expression
+;;      (pattern  action+)*)
+;;
+;;      --- or ---
+;;
+;;  (select-match expression
+;;      pattern => expression
+;;      pattern => expression
+;;      ...)
+;;
+;;  pattern ->  constant		;egs  1, #\x, #c(1.0 1.1)
+;;          |   symbol                  ;matches anything
+;;          |   'anything               ;must be EQUAL
+;;          |   (pattern = pattern)     ;both patterns must match
+;;          |   (#'function pattern)    ;predicate test
+;;          |   (pattern . pattern)	;cons cell
+;;
+
+;;  Example
+;;
+;;  (select-match item
+;;      (('if e1 e2 e3) 'if-then-else)				;(1)
+;;      ((#'oddp k)     'an-odd-integer)			;(2)
+;;      (((#'treep tree) = (hd . tl))   'something-else)	;(3)
+;;      (other          'anything-else))			;(4)
+;;
+;;  Notes
+;;
+;;  .   Each pattern is tested in turn.  The first match is taken.
+;;
+;;  .   If no pattern matches, an error is signalled.
+;;
+;;  .   Constant patterns (things X for which (CONSTANTP X) is true, i.e.
+;;      numbers, strings, characters, etc.) match things which are EQUAL.
+;;
+;;  .   Quoted patterns (which are CONSTANTP) are constants.
+;;
+;;  .   Symbols match anything. The symbol is bound to the matched item
+;;      for the execution of the actions.
+;;      For example, (SELECT-MATCH '(1 2 3)
+;;                      (1 . X) => X)
+;;      returns (2 3) because X is bound to the cdr of the candidate.
+;;
+;;  .   The two pattern match (p1 = p2) can be used to name parts
+;;      of the matched structure.  For example, (ALL = (HD . TL))
+;;      matches a cons cell. ALL is bound to the cons cell, HD to its car
+;;      and TL to its tail.
+;;
+;;  .   A predicate test applies the predicate to the item being matched.
+;;      If the predicate returns NIL then the match fails.
+;;      If it returns truth, then the nested pattern is matched.  This is
+;;      often just a symbol like K in the example.
+;;
+;;  .   Care should be taken with the domain values for predicate matches.
+;;      If, in the above eg, item is not an integer, an error would occur
+;;      during the test.  A safer pattern would be
+;;          (#'integerp (#'oddp k))
+;;      This would only test for oddness of the item was an integer.
+;;
+;;  .   A single symbol will match anything so it can be used as a default
+;;      case, like OTHER above.
+;;
+
+(in-package swank/match)
+
+(defmacro match (expression &body patterns)
+  `(select-match ,expression ,@patterns))
+
+(defmacro select-match (expression &rest patterns)
+  (let* ((do-let (not (atom expression)))
+         (key    (if do-let (gensym) expression))
+         (cbody  (expand-select-patterns key patterns))
+         (cform  `(cond . ,cbody)))
+    (if do-let
+        `(let ((,key ,expression)) ,cform)
+        cform)))
+
+(defun expand-select-patterns (key patterns)
+  (if (eq (second patterns) '=>)
+      (expand-select-patterns-style-2 key patterns)
+      (expand-select-patterns-style-1 key patterns)))
+
+(defun expand-select-patterns-style-1 (key patterns)
+  (if (null patterns)
+      `((t (error "Case select pattern match failure on ~S" ,key)))
+      (let* ((pattern  (caar patterns))
+             (actions  (cdar patterns))
+             (rest     (cdr patterns))
+             (test     (compile-select-test key pattern))
+             (bindings (compile-select-bindings key pattern actions)))
+        `(,(if bindings `(,test (let ,bindings . ,actions))
+               `(,test . ,actions))
+           . ,(unless (eq test t)
+                (expand-select-patterns-style-1 key rest))))))
+
+(defun expand-select-patterns-style-2 (key patterns)
+  (cond ((null patterns)
+         `((t (error "Case select pattern match failure on ~S" ,key))))
+        (t (when (or (< (length patterns) 3)
+                     (not (eq (second patterns) '=>)))
+             (error "Illegal patterns: ~S" patterns))
+           (let* ((pattern  (first patterns))
+                  (actions  (list (third patterns)))
+                  (rest     (cdddr patterns))
+                  (test     (compile-select-test key pattern))
+                  (bindings (compile-select-bindings key pattern actions)))
+             `(,(if bindings `(,test (let ,bindings . ,actions))
+                    `(,test . ,actions))
+                . ,(unless (eq test t)
+                     (expand-select-patterns-style-2 key rest)))))))
+
+(defun compile-select-test (key pattern)
+  (let ((tests (remove t (compile-select-tests key pattern))))
+    (cond
+      ;; note AND does this anyway, but this allows us to tell if
+      ;; the pattern will always match.
+      ((null tests)         t)
+      ((= (length tests) 1) (car tests))
+      (t                    `(and . ,tests)))))
+
+(defun compile-select-tests (key pattern)
+  (cond ((constantp pattern)   `((,(cond ((numberp pattern) 'eql)
+                                         ((symbolp pattern) 'eq)
+                                         (t                'equal))
+                                   ,key ,pattern)))
+        ((symbolp pattern)      '(t))
+        ((select-double-match? pattern)
+         (append
+          (compile-select-tests key (first pattern))
+          (compile-select-tests key (third pattern))))
+        ((select-predicate? pattern)
+         (append
+          `((,(second (first pattern)) ,key))
+          (compile-select-tests key (second pattern))))
+        ((consp pattern)
+         (append
+          `((consp ,key))
+          (compile-select-tests (cs-car key) (car
+                                               pattern))
+          (compile-select-tests (cs-cdr key) (cdr
+                                               pattern))))
+        (t (error "Illegal select pattern: ~S" pattern))))
+
+
+(defun compile-select-bindings (key pattern action)
+  (cond ((constantp pattern) '())
+        ((symbolp pattern)
+         (if (select-in-tree pattern action)
+             `((,pattern ,key))
+             '()))
+        ((select-double-match? pattern)
+         (append
+          (compile-select-bindings key (first pattern) action)
+          (compile-select-bindings key (third pattern) action)))
+        ((select-predicate? pattern)
+         (compile-select-bindings key (second pattern) action))
+        ((consp pattern)
+         (append
+          (compile-select-bindings (cs-car key) (car pattern)
+                                   action)
+          (compile-select-bindings (cs-cdr key) (cdr pattern)
+                                   action)))))
+
+(defun select-in-tree (atom tree)
+  (or (eq atom tree)
+      (if (consp tree)
+          (or (select-in-tree atom (car tree))
+              (select-in-tree atom (cdr tree))))))
+
+(defun select-double-match? (pattern)
+  ;;  (<pattern> = <pattern>)
+  (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
+       (null (cdddr pattern))
+       (eq (second pattern) '=)))
+
+(defun select-predicate? (pattern)
+  ;; ((function <f>) <pattern>)
+  (and (consp pattern)
+       (consp (cdr pattern))
+       (null (cddr pattern))
+       (consp (first pattern))
+       (consp (cdr (first pattern)))
+       (null (cddr (first pattern)))
+       (eq (caar pattern) 'function)))
+
+(defun cs-car (exp)
+  (cs-car/cdr 'car exp
+               '((car . caar)     (cdr . cadr)    (caar . caaar) (cadr . caadr)
+                 (cdar . cadar)   (cddr . caddr)
+                 (caaar . caaaar) (caadr . caaadr) (cadar . caadar)
+                 (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr)
+                 (cddar . caddar) (cdddr . cadddr))))
+
+(defun cs-cdr (exp)
+  (cs-car/cdr 'cdr exp
+               '((car . cdar)    (cdr . cddr)    (caar . cdaar)  (cadr . cdadr)
+                 (cdar . cddar)  (cddr . cdddr)
+                 (caaar . cdaaar)    (caadr . cdaadr)    (cadar . cdadar)
+                 (caddr . cdaddr)    (cdaar . cddaar)    (cdadr . cddadr)
+                 (cddar . cdddar)    (cdddr . cddddr))))
+
+(defun cs-car/cdr (op exp table)
+  (if (and (consp exp) (= (length exp) 2))
+      (let ((replacement  (assoc (car exp) table)))
+        (if replacement
+            `(,(cdr replacement) ,(second exp))
+            `(,op ,exp)))
+      `(,op ,exp)))
+
+;; (setf c1 '(select-match x (a 1) (b 2 3 4)))
+;; (setf c2 '(select-match (car y)
+;;             (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+
+;;  else))))
+;; (setf c3 '(select-match (caddr y)
+;;             ((all = (x y)) (list x y all))
+;;             ((a '= b)      (list 'assign a b))
+;;             ((#'oddp k)     (1+ k)))))
+
+

sources_non_forked/slimv/slime/swank/mezzano.lisp

@@ -0,0 +1,700 @@
+;;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-mezzano.lisp --- SLIME backend for Mezzano
+;;;
+;;; This code has been placed in the Public Domain.  All warranties are
+;;; disclaimed.
+;;;
+
+;;; Administrivia
+
+(defpackage swank/mezzano
+  (:use cl swank/backend))
+
+(in-package swank/mezzano)
+
+;;; swank-mop
+
+(import-swank-mop-symbols :mezzano.clos '(:class-default-initargs
+                                          :class-direct-default-initargs
+                                          :specializer-direct-methods
+                                          :generic-function-declarations))
+
+(defun swank-mop:specializer-direct-methods (obj)
+  (declare (ignore obj))
+  '())
+
+(defun swank-mop:generic-function-declarations (gf)
+  (declare (ignore gf))
+  '())
+
+(defimplementation gray-package-name ()
+  "MEZZANO.GRAY")
+
+;;;; TCP server
+
+(defclass listen-socket ()
+  ((%listener :initarg :listener)))
+
+(defimplementation create-socket (host port &key backlog)
+  (make-instance 'listen-socket
+                 :listener (mezzano.network.tcp:tcp-listen
+                            host
+                            port
+                            :backlog (or backlog 10))))
+
+(defimplementation local-port (socket)
+  (mezzano.network.tcp:tcp-listener-local-port (slot-value socket '%listener)))
+
+(defimplementation close-socket (socket)
+  (mezzano.network.tcp:close-tcp-listener (slot-value socket '%listener)))
+
+(defimplementation accept-connection (socket &key external-format
+                                             buffering timeout)
+  (declare (ignore external-format buffering timeout))
+  (loop
+    (let ((value (mezzano.network.tcp:tcp-accept (slot-value socket '%listener)
+                                                 :wait-p nil)))
+      (if value
+          (return value)
+          ;; Poke standard-input every now and then to keep the console alive.
+          (progn (listen)
+                 (sleep 0.05))))))
+
+(defimplementation preferred-communication-style ()
+  :spawn)
+
+;;;; Unix signals
+;;;; ????
+
+(defimplementation getpid ()
+  0)
+
+;;;; Compilation
+
+(defun signal-compiler-condition (condition severity)
+  (signal 'compiler-condition
+          :original-condition condition
+          :severity severity
+          :message (format nil "~A" condition)
+          :location nil))
+
+(defimplementation call-with-compilation-hooks (func)
+  (handler-bind
+      ((error
+        (lambda (c)
+          (signal-compiler-condition c :error)))
+       (warning
+        (lambda (c)
+          (signal-compiler-condition c :warning)))
+       (style-warning
+        (lambda (c)
+          (signal-compiler-condition c :style-warning))))
+    (funcall func)))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+                                                line column policy)
+  (declare (ignore buffer line column policy))
+  (let* ((*load-pathname* (ignore-errors (pathname filename)))
+         (*load-truename* (when *load-pathname*
+                            (ignore-errors (truename *load-pathname*))))
+         (sys.int::*top-level-form-number* `(:position ,position)))
+    (with-compilation-hooks ()
+      (eval (read-from-string (concatenate 'string "(progn " string " )")))))
+  t)
+
+(defimplementation swank-compile-file (input-file output-file load-p
+                                                  external-format
+                                                  &key policy)
+  (with-compilation-hooks ()
+    (multiple-value-prog1
+        (compile-file input-file
+                      :output-file output-file
+                      :external-format external-format)
+      (when load-p
+        (load output-file)))))
+
+(defimplementation find-external-format (coding-system)
+  (if (or (equal coding-system "utf-8")
+          (equal coding-system "utf-8-unix"))
+      :default
+      nil))
+
+;;;; Debugging
+
+;; Definitely don't allow this.
+(defimplementation install-debugger-globally (function)
+  (declare (ignore function))
+  nil)
+
+(defvar *current-backtrace*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+  (let ((*current-backtrace* '()))
+    (let ((prev-fp nil))
+      (sys.int::map-backtrace
+       (lambda (i fp)
+         (push (list (1- i) fp prev-fp) *current-backtrace*)
+         (setf prev-fp fp))))
+    (setf *current-backtrace* (reverse *current-backtrace*))
+    ;; Drop the topmost frame, which is finished call to MAP-BACKTRACE.
+    (pop *current-backtrace*)
+    ;; And the next one for good measure.
+    (pop *current-backtrace*)
+    (funcall debugger-loop-fn)))
+
+(defimplementation compute-backtrace (start end)
+  (subseq *current-backtrace* start end))
+
+(defimplementation print-frame (frame stream)
+  (format stream "~S" (sys.int::function-from-frame frame)))
+
+(defimplementation frame-source-location (frame-number)
+  (let* ((frame (nth frame-number *current-backtrace*))
+         (fn (sys.int::function-from-frame frame)))
+    (function-location fn)))
+
+(defimplementation frame-locals (frame-number)
+  (loop
+     with frame = (nth frame-number *current-backtrace*)
+     for (name id location repr) in (sys.int::frame-locals frame)
+     collect (list :name name
+                   :id id
+                   :value (sys.int::read-frame-slot frame location repr))))
+
+(defimplementation frame-var-value (frame-number var-id)
+  (let* ((frame (nth frame-number *current-backtrace*))
+         (locals (sys.int::frame-locals frame))
+         (info (nth var-id locals)))
+    (if info
+        (destructuring-bind (name id location repr)
+            info
+          (declare (ignore id))
+          (values (sys.int::read-frame-slot frame location repr) name))
+        (error "Invalid variable id ~D for frame number ~D."
+               var-id frame-number))))
+
+;;;; Definition finding
+
+(defun top-level-form-position (pathname tlf)
+  (ignore-errors
+    (with-open-file (s pathname)
+      (loop
+         repeat tlf
+         do (with-standard-io-syntax
+              (let ((*read-suppress* t)
+                    (*read-eval* nil))
+                (read s nil))))
+      (let ((default (make-pathname :host (pathname-host s))))
+        (make-location `(:file ,(enough-namestring s default))
+                       `(:position ,(1+ (file-position s))))))))
+
+(defun function-location (function)
+  "Return a location object for FUNCTION."
+  (let* ((info (sys.int::function-debug-info function))
+         (pathname (sys.int::debug-info-source-pathname info))
+         (tlf (sys.int::debug-info-source-top-level-form-number info)))
+    (cond ((and (consp tlf)
+                (eql (first tlf) :position))
+           (let ((default (make-pathname :host (pathname-host pathname))))
+             (make-location `(:file ,(enough-namestring pathname default))
+                            `(:position ,(second tlf)))))
+          (t
+           (top-level-form-position pathname tlf)))))
+
+(defun method-definition-name (name method)
+  `(defmethod ,name
+       ,@(mezzano.clos:method-qualifiers method)
+     ,(mapcar (lambda (x)
+                (typecase x
+                  (mezzano.clos:class
+                   (mezzano.clos:class-name x))
+                  (mezzano.clos:eql-specializer
+                   `(eql ,(mezzano.clos:eql-specializer-object x)))
+                  (t x)))
+              (mezzano.clos:method-specializers method))))
+
+(defimplementation find-definitions (name)
+  (let ((result '()))
+    (labels
+        ((frob-fn (dspec fn)
+           (let ((loc (function-location fn)))
+             (when loc
+               (push (list dspec loc) result))))
+         (try-fn (name)
+           (when (valid-function-name-p name)
+             (when (and (fboundp name)
+                        (not (and (symbolp name)
+                                  (or (special-operator-p name)
+                                      (macro-function name)))))
+               (let ((fn (fdefinition name)))
+                 (cond ((typep fn 'mezzano.clos:standard-generic-function)
+                        (dolist (m (mezzano.clos:generic-function-methods fn))
+                          (frob-fn (method-definition-name name m)
+                                   (mezzano.clos:method-function m))))
+                       (t
+                        (frob-fn `(defun ,name) fn)))))
+             (when (compiler-macro-function name)
+               (frob-fn `(define-compiler-macro ,name)
+                        (compiler-macro-function name))))))
+      (try-fn name)
+      (try-fn `(setf name))
+      (try-fn `(sys.int::cas name))
+      (when (and (symbolp name)
+                 (get name 'sys.int::setf-expander))
+        (frob-fn `(define-setf-expander ,name)
+                 (get name 'sys.int::setf-expander)))
+      (when (and (symbolp name)
+                 (macro-function name))
+        (frob-fn `(defmacro ,name)
+                 (macro-function name))))
+    result))
+
+;;;; XREF
+;;; Simpler variants.
+
+(defun find-all-frefs ()
+  (let ((frefs (make-array 500 :adjustable t :fill-pointer 0))
+        (keep-going t))
+    (loop
+       (when (not keep-going)
+         (return))
+       (adjust-array frefs (* (array-dimension frefs 0) 2))
+       (setf keep-going nil
+             (fill-pointer frefs) 0)
+       ;; Walk the wired area looking for FREFs.
+       (sys.int::walk-area
+        :wired
+        (lambda (object address size)
+          (when (sys.int::function-reference-p object)
+            (when (not (vector-push object frefs))
+              (setf keep-going t))))))
+    (remove-duplicates (coerce frefs 'list))))
+
+(defimplementation list-callers (function-name)
+  (let ((fref-for-fn (sys.int::function-reference function-name))
+        (callers '()))
+    (loop
+       for fref in (find-all-frefs)
+       for fn = (sys.int::function-reference-function fref)
+       for name = (sys.int::function-reference-name fref)
+       when fn
+       do
+         (cond ((typep fn 'standard-generic-function)
+                (dolist (m (mezzano.clos:generic-function-methods fn))
+                  (let* ((mf (mezzano.clos:method-function m))
+                         (mf-frefs (get-all-frefs-in-function mf)))
+                    (when (member fref-for-fn mf-frefs)
+                      (push `((defmethod ,name
+                                  ,@(mezzano.clos:method-qualifiers m)
+                                ,(mapcar #'specializer-name
+                                         (mezzano.clos:method-specializers m)))
+                              ,(function-location mf))
+                            callers)))))
+               ((member fref-for-fn
+                        (get-all-frefs-in-function fn))
+                (push `((defun ,name) ,(function-location fn)) callers))))
+    callers))
+
+(defun specializer-name (specializer)
+  (if (typep specializer 'standard-class)
+      (mezzano.clos:class-name specializer)
+      specializer))
+
+(defun get-all-frefs-in-function (function)
+  (when (sys.int::funcallable-std-instance-p function)
+    (setf function (sys.int::funcallable-std-instance-function function)))
+  (when (sys.int::closure-p function)
+    (setf function (sys.int::%closure-function function)))
+  (loop
+     for i below (sys.int::function-pool-size function)
+     for entry = (sys.int::function-pool-object function i)
+     when (sys.int::function-reference-p entry)
+     collect entry
+     when (compiled-function-p entry) ; closures
+     append (get-all-frefs-in-function entry)))
+
+(defimplementation list-callees (function-name)
+  (let* ((fn (fdefinition function-name))
+         ;; Grovel around in the function's constant pool looking for
+         ;; function-references.  These may be for #', but they're
+         ;; probably going to be for normal calls.
+         ;; TODO: This doesn't work well on interpreted functions or
+         ;; funcallable instances.
+         (callees (remove-duplicates (get-all-frefs-in-function fn))))
+    (loop
+       for fref in callees
+       for name = (sys.int::function-reference-name fref)
+       for fn = (sys.int::function-reference-function fref)
+       when fn
+       collect `((defun ,name) ,(function-location fn)))))
+
+;;;; Documentation
+
+(defimplementation arglist (name)
+  (let ((macro (when (symbolp name)
+                 (macro-function name)))
+        (fn (if (functionp name)
+                name
+                (ignore-errors (fdefinition name)))))
+    (cond
+      (macro
+       (get name 'sys.int::macro-lambda-list))
+      (fn
+       (cond
+         ((typep fn 'mezzano.clos:standard-generic-function)
+          (mezzano.clos:generic-function-lambda-list fn))
+         (t
+          (function-lambda-list fn))))
+      (t :not-available))))
+
+(defun function-lambda-list (function)
+  (sys.int::debug-info-lambda-list
+   (sys.int::function-debug-info function)))
+
+(defimplementation type-specifier-p (symbol)
+  (cond
+    ((or (get symbol 'sys.int::type-expander)
+         (get symbol 'sys.int::compound-type)
+         (get symbol 'sys.int::type-symbol))
+     t)
+    (t :not-available)))
+
+(defimplementation function-name (function)
+  (sys.int::function-name function))
+
+(defimplementation valid-function-name-p (form)
+  "Is FORM syntactically valid to name a function?
+   If true, FBOUNDP should not signal a type-error for FORM."
+  (flet ((length=2 (list)
+           (and (not (null (cdr list))) (null (cddr list)))))
+    (or (symbolp form)
+        (and (consp form) (length=2 form)
+             (or (eq (first form) 'setf)
+                 (eq (first form) 'sys.int::cas))
+             (symbolp (second form))))))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+  (let ((result '()))
+    (when (boundp symbol)
+      (setf (getf result :variable) nil))
+    (when (and (fboundp symbol)
+               (not (macro-function symbol)))
+      (setf (getf result :function)
+            (function-docstring symbol)))
+    (when (fboundp `(setf ,symbol))
+      (setf (getf result :setf)
+            (function-docstring `(setf ,symbol))))
+    (when (get symbol 'sys.int::setf-expander)
+      (setf (getf result :setf) nil))
+    (when (special-operator-p symbol)
+      (setf (getf result :special-operator) nil))
+    (when (macro-function symbol)
+      (setf (getf result :macro) nil))
+    (when (compiler-macro-function symbol)
+      (setf (getf result :compiler-macro) nil))
+    (when (type-specifier-p symbol)
+      (setf (getf result :type) nil))
+    (when (find-class symbol nil)
+      (setf (getf result :class) nil))
+    result))
+
+(defun function-docstring (function-name)
+  (let* ((definition (fdefinition function-name))
+         (debug-info (sys.int::function-debug-info definition)))
+    (sys.int::debug-info-docstring debug-info)))
+
+;;;; Multithreading
+
+;; FIXME: This should be a weak table.
+(defvar *thread-ids-for-emacs* (make-hash-table))
+(defvar *next-thread-id-for-emacs* 0)
+(defvar *thread-id-for-emacs-lock* (mezzano.supervisor:make-mutex
+                                    "SWANK thread ID table"))
+
+(defimplementation spawn (fn &key name)
+  (mezzano.supervisor:make-thread fn :name name))
+
+(defimplementation thread-id (thread)
+  (mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*)
+    (let ((id (gethash thread *thread-ids-for-emacs*)))
+      (when (null id)
+        (setf id (incf *next-thread-id-for-emacs*)
+              (gethash thread *thread-ids-for-emacs*) id
+              (gethash id *thread-ids-for-emacs*) thread))
+      id)))
+
+(defimplementation find-thread (id)
+  (mezzano.supervisor:with-mutex (*thread-id-for-emacs-lock*)
+    (gethash id *thread-ids-for-emacs*)))
+
+(defimplementation thread-name (thread)
+  (mezzano.supervisor:thread-name thread))
+
+(defimplementation thread-status (thread)
+  (format nil "~:(~A~)" (mezzano.supervisor:thread-state thread)))
+
+(defimplementation current-thread ()
+  (mezzano.supervisor:current-thread))
+
+(defimplementation all-threads ()
+  (mezzano.supervisor:all-threads))
+
+(defimplementation thread-alive-p (thread)
+  (not (eql (mezzano.supervisor:thread-state thread) :dead)))
+
+(defimplementation interrupt-thread (thread fn)
+  (mezzano.supervisor:establish-thread-foothold thread fn))
+
+(defimplementation kill-thread (thread)
+  ;; Documentation says not to execute unwind-protected sections, but there's
+  ;; no way to do that.
+  ;; And killing threads at arbitrary points without unwinding them is a good
+  ;; way to hose the system.
+  (mezzano.supervisor:terminate-thread thread))
+
+(defvar *mailbox-lock* (mezzano.supervisor:make-mutex "mailbox lock"))
+(defvar *mailboxes* (list))
+
+(defstruct (mailbox (:conc-name mailbox.))
+  thread
+  (mutex (mezzano.supervisor:make-mutex))
+  (queue '() :type list))
+
+(defun mailbox (thread)
+  "Return THREAD's mailbox."
+  ;; Use weak pointers to avoid holding on to dead threads forever.
+  (mezzano.supervisor:with-mutex (*mailbox-lock*)
+    ;; Flush forgotten threads.
+    (setf *mailboxes*
+          (remove-if-not #'sys.int::weak-pointer-value *mailboxes*))
+    (loop
+       for entry in *mailboxes*
+       do
+         (multiple-value-bind (key value livep)
+             (sys.int::weak-pointer-pair entry)
+           (when (eql key thread)
+             (return value)))
+       finally
+         (let ((mb (make-mailbox :thread thread)))
+           (push (sys.int::make-weak-pointer thread mb) *mailboxes*)
+           (return mb)))))
+
+(defimplementation send (thread message)
+  (let* ((mbox (mailbox thread))
+         (mutex (mailbox.mutex mbox)))
+    (mezzano.supervisor:with-mutex (mutex)
+      (setf (mailbox.queue mbox)
+            (nconc (mailbox.queue mbox) (list message))))))
+
+(defvar *receive-if-sleep-time* 0.02)
+
+(defimplementation receive-if (test &optional timeout)
+  (let* ((mbox (mailbox (current-thread)))
+         (mutex (mailbox.mutex mbox)))
+    (assert (or (not timeout) (eq timeout t)))
+    (loop
+       (check-slime-interrupts)
+       (mezzano.supervisor:with-mutex (mutex)
+         (let* ((q (mailbox.queue mbox))
+                (tail (member-if test q)))
+           (when tail
+             (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
+             (return (car tail))))
+         (when (eq timeout t) (return (values nil t))))
+       (sleep *receive-if-sleep-time*))))
+
+(defvar *registered-threads* (make-hash-table))
+(defvar *registered-threads-lock*
+  (mezzano.supervisor:make-mutex "registered threads lock"))
+
+(defimplementation register-thread (name thread)
+  (declare (type symbol name))
+  (mezzano.supervisor:with-mutex (*registered-threads-lock*)
+    (etypecase thread
+      (null
+       (remhash name *registered-threads*))
+      (mezzano.supervisor:thread
+       (setf (gethash name *registered-threads*) thread))))
+  nil)
+
+(defimplementation find-registered (name)
+  (mezzano.supervisor:with-mutex (*registered-threads-lock*)
+    (values (gethash name *registered-threads*))))
+
+(defimplementation wait-for-input (streams &optional timeout)
+  (loop
+       (let ((ready '()))
+         (dolist (s streams)
+           (when (or (listen s)
+                     (and (typep s 'mezzano.network.tcp::tcp-stream)
+                          (mezzano.network.tcp::tcp-connection-closed-p s)))
+             (push s ready)))
+         (when ready
+           (return ready))
+         (when (check-slime-interrupts)
+           (return :interrupt))
+         (when timeout
+           (return '()))
+         (sleep 1)
+         (when (numberp timeout)
+           (decf timeout 1)
+           (when (not (plusp timeout))
+             (return '()))))))
+
+;;;;  Locks
+
+(defstruct recursive-lock
+  mutex
+  (depth 0))
+
+(defimplementation make-lock (&key name)
+  (make-recursive-lock
+   :mutex (mezzano.supervisor:make-mutex name)))
+
+(defimplementation call-with-lock-held (lock function)
+  (cond ((mezzano.supervisor:mutex-held-p
+          (recursive-lock-mutex lock))
+         (unwind-protect
+              (progn (incf (recursive-lock-depth lock))
+                     (funcall function))
+           (decf (recursive-lock-depth lock))))
+        (t
+         (mezzano.supervisor:with-mutex ((recursive-lock-mutex lock))
+           (multiple-value-prog1
+               (funcall function)
+             (assert (eql (recursive-lock-depth lock) 0)))))))
+
+;;;; Character names
+
+(defimplementation character-completion-set (prefix matchp)
+  ;; TODO: Unicode characters too.
+  (loop
+     for names in sys.int::*char-name-alist*
+     append
+       (loop
+          for name in (rest names)
+          when (funcall matchp prefix name)
+          collect name)))
+
+;;;; Inspector
+
+(defmethod emacs-inspect ((o function))
+  (case (sys.int::%object-tag o)
+    (#.sys.int::+object-tag-function+
+     (label-value-line*
+      (:name (sys.int::function-name o))
+      (:arglist (arglist o))
+      (:debug-info (sys.int::function-debug-info o))))
+    (#.sys.int::+object-tag-closure+
+     (append
+      (label-value-line :function (sys.int::%closure-function o))
+      `("Closed over values:" (:newline))
+      (loop
+         for i below (sys.int::%closure-length o)
+         append (label-value-line i (sys.int::%closure-value o i)))))
+    (t
+     (call-next-method))))
+
+(defmethod emacs-inspect ((o sys.int::weak-pointer))
+  (label-value-line*
+   (:key (sys.int::weak-pointer-key o))
+   (:value (sys.int::weak-pointer-value o))))
+
+(defmethod emacs-inspect ((o sys.int::function-reference))
+  (label-value-line*
+   (:name (sys.int::function-reference-name o))
+   (:function (sys.int::function-reference-function o))))
+
+(defmethod emacs-inspect ((object structure-object))
+  (let ((class (class-of object)))
+    `("Class: " (:value ,class) (:newline)
+                ,@(swank::all-slots-for-inspector object))))
+
+(in-package :swank)
+
+(defmethod all-slots-for-inspector ((object structure-object))
+  (let* ((class           (class-of object))
+         (direct-slots    (swank-mop:class-direct-slots class))
+         (effective-slots (swank-mop:class-slots class))
+         (longest-slot-name-length
+          (loop for slot :in effective-slots
+                maximize (length (symbol-name
+                                  (swank-mop:slot-definition-name slot)))))
+         (checklist
+          (reinitialize-checklist
+           (ensure-istate-metadata object :checklist
+                                   (make-checklist (length effective-slots)))))
+         (grouping-kind
+          ;; We box the value so we can re-set it.
+          (ensure-istate-metadata object :grouping-kind
+                                  (box *inspector-slots-default-grouping*)))
+         (sort-order
+          (ensure-istate-metadata object :sort-order
+                                  (box *inspector-slots-default-order*)))
+         (sort-predicate (ecase (ref sort-order)
+                           (:alphabetically #'string<)
+                           (:unsorted (constantly nil))))
+         (sorted-slots (sort (copy-seq effective-slots)
+                             sort-predicate
+                             :key #'swank-mop:slot-definition-name))
+         (effective-slots
+          (ecase (ref grouping-kind)
+            (:all sorted-slots)
+            (:inheritance (stable-sort-by-inheritance sorted-slots
+                                                      class sort-predicate)))))
+    `("--------------------"
+      (:newline)
+      " Group slots by inheritance "
+      (:action ,(ecase (ref grouping-kind)
+                       (:all "[ ]")
+                       (:inheritance "[X]"))
+               ,(lambda ()
+                        ;; We have to do this as the order of slots will
+                        ;; be sorted differently.
+                        (fill (checklist.buttons checklist) nil)
+                        (setf (ref grouping-kind)
+                              (ecase (ref grouping-kind)
+                                (:all :inheritance)
+                                (:inheritance :all))))
+               :refreshp t)
+      (:newline)
+      " Sort slots alphabetically  "
+      (:action ,(ecase (ref sort-order)
+                       (:unsorted "[ ]")
+                       (:alphabetically "[X]"))
+               ,(lambda ()
+                        (fill (checklist.buttons checklist) nil)
+                        (setf (ref sort-order)
+                              (ecase (ref sort-order)
+                                (:unsorted :alphabetically)
+                                (:alphabetically :unsorted))))
+               :refreshp t)
+      (:newline)
+      ,@ (case (ref grouping-kind)
+           (:all
+            `((:newline)
+              "All Slots:"
+              (:newline)
+              ,@(make-slot-listing checklist object class
+                                   effective-slots direct-slots
+                                   longest-slot-name-length)))
+           (:inheritance
+            (list-all-slots-by-inheritance checklist object class
+                                           effective-slots direct-slots
+                                           longest-slot-name-length)))
+      (:newline)
+      (:action "[set value]"
+               ,(lambda ()
+                        (do-checklist (idx checklist)
+                          (query-and-set-slot class object
+                                              (nth idx effective-slots))))
+               :refreshp t)
+      "  "
+      (:action "[make unbound]"
+               ,(lambda ()
+                        (do-checklist (idx checklist)
+                          (swank-mop:slot-makunbound-using-class
+                           class object (nth idx effective-slots))))
+               :refreshp t)
+      (:newline))))

sources_non_forked/slimv/slime/swank/mkcl.lisp

@@ -0,0 +1,933 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-mkcl.lisp --- SLIME backend for MKCL.
+;;;
+;;; This code has been placed in the Public Domain.  All warranties
+;;; are disclaimed.
+;;;
+
+;;; Administrivia
+
+(defpackage swank/mkcl
+  (:use cl swank/backend))
+
+(in-package swank/mkcl)
+
+;;(declaim (optimize (debug 3)))
+
+(defvar *tmp*)
+
+(defimplementation gray-package-name ()
+  '#:gray)
+
+(eval-when (:compile-toplevel :load-toplevel)
+
+  (swank/backend::import-swank-mop-symbols :clos
+    ;;  '(:eql-specializer
+    ;;    :eql-specializer-object
+    ;;    :generic-function-declarations
+    ;;    :specializer-direct-methods
+    ;;    :compute-applicable-methods-using-classes)
+    nil
+    ))
+
+
+;;; UTF8
+
+(defimplementation string-to-utf8 (string)
+  (mkcl:octets (si:utf-8 string)))
+
+(defimplementation utf8-to-string (octets)
+  (string (si:utf-8 octets)))
+
+
+;;;; TCP Server
+
+(eval-when (:compile-toplevel :load-toplevel)
+  ;; At compile-time we need access to the sb-bsd-sockets package for the
+  ;; the following code to be read properly.
+  ;; It is a bit a shame we have to load the entire module to get that.
+  (require 'sockets))
+
+
+(defun resolve-hostname (name)
+  (car (sb-bsd-sockets:host-ent-addresses
+        (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port &key backlog)
+  (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+			       :type :stream
+			       :protocol :tcp)))
+    (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+    (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
+    (sb-bsd-sockets:socket-listen socket (or backlog 5))
+    socket))
+
+(defimplementation local-port (socket)
+  (nth-value 1 (sb-bsd-sockets:socket-name socket)))
+
+(defimplementation close-socket (socket)
+  (sb-bsd-sockets:socket-close socket))
+
+(defun accept (socket)
+  "Like socket-accept, but retry on EINTR."
+  (loop (handler-case
+            (return (sb-bsd-sockets:socket-accept socket))
+          (sb-bsd-sockets:interrupted-error ()))))
+
+(defimplementation accept-connection (socket
+                                      &key external-format
+                                      buffering timeout)
+  (declare (ignore timeout))
+  (sb-bsd-sockets:socket-make-stream (accept socket)
+                                     :output t ;; bogus
+                                     :input t ;; bogus
+                                     :buffering buffering ;; bogus
+                                     :element-type (if external-format
+                                                       'character 
+                                                     '(unsigned-byte 8))
+                                     :external-format external-format
+                                     ))
+
+(defimplementation preferred-communication-style ()
+  :spawn
+  )
+
+(defvar *external-format-to-coding-system*
+  '((:iso-8859-1
+     "latin-1" "latin-1-unix" "iso-latin-1-unix" 
+     "iso-8859-1" "iso-8859-1-unix")
+    (:utf-8 "utf-8" "utf-8-unix")))
+
+(defun external-format (coding-system)
+  (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+                      *external-format-to-coding-system*))
+      (find coding-system (si:all-encodings) :test #'string-equal)))
+
+(defimplementation find-external-format (coding-system)
+  #+unicode (external-format coding-system)
+  ;; Without unicode support, MKCL uses the one-byte encoding of the
+  ;; underlying OS, and will barf on anything except :DEFAULT.  We
+  ;; return NIL here for known multibyte encodings, so
+  ;; SWANK:CREATE-SERVER will barf.
+  #-unicode (let ((xf (external-format coding-system)))
+              (if (member xf '(:utf-8))
+                  nil
+                :default)))
+
+
+
+;;;; Unix signals
+
+(defimplementation install-sigint-handler (handler)
+  (let ((old-handler (symbol-function 'si:terminal-interrupt)))
+    (setf (symbol-function 'si:terminal-interrupt)
+          (if (consp handler)
+              (car handler)
+              (lambda (&rest args)
+                (declare (ignore args))
+                (funcall handler)
+                (continue))))
+    (list old-handler)))
+
+
+(defimplementation getpid ()
+  (mkcl:getpid))
+
+(defimplementation set-default-directory (directory)
+  (mk-ext::chdir (namestring directory))
+  (default-directory))
+
+(defimplementation default-directory ()
+  (namestring (mk-ext:getcwd)))
+
+(defmacro progf (plist &rest forms)
+  `(let (_vars _vals)
+     (do ((p ,plist (cddr p)))
+         ((endp p))
+         (push (car p) _vars)
+         (push (cadr p) _vals))
+     (progv _vars _vals ,@forms)
+     )
+  )
+
+(defvar *inferior-lisp-sleeping-post* nil)
+
+(defimplementation quit-lisp ()
+  (progf (ignore-errors (eval (read-from-string "swank::*saved-global-streams*"))) ;; restore original IO streams.
+         (when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*))
+         ;;(mk-ext:quit :verbose t)
+         ))
+
+
+;;;; Compilation
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename*)
+
+(defun signal-compiler-condition (&rest args)
+  (signal (apply #'make-condition 'compiler-condition args)))
+
+#|
+(defun handle-compiler-warning (condition)
+  (signal-compiler-condition
+   :original-condition condition
+   :message (format nil "~A" condition)
+   :severity :warning
+   :location
+   (if *buffer-name*
+       (make-location (list :buffer *buffer-name*)
+                      (list :offset *buffer-start-position* 0))
+       ;; ;; compiler::*current-form*
+       ;; (if compiler::*current-function*
+       ;;     (make-location (list :file *compile-filename*)
+       ;;                    (list :function-name   
+       ;;                          (symbol-name
+       ;;                           (slot-value compiler::*current-function*
+       ;;                                       'compiler::name))))
+       (list :error "No location found.")
+           ;; )
+       )))
+|#
+
+#|
+(defun condition-location (condition)
+  (let ((file     (compiler:compiler-message-file condition))
+        (position (compiler:compiler-message-file-position condition)))
+    (if (and position (not (minusp position)))
+        (if *buffer-name*
+            (make-buffer-location *buffer-name*
+                                  *buffer-start-position*
+                                  position)
+            (make-file-location file position))
+        (make-error-location "No location found."))))
+|#
+
+(defun condition-location (condition)
+  (if *buffer-name*
+      (make-location (list :buffer *buffer-name*)
+                     (list :offset *buffer-start-position* 0))
+       ;; ;; compiler::*current-form*   ;
+       ;; (if compiler::*current-function* ;
+       ;;     (make-location (list :file *compile-filename*) ;
+       ;;                    (list :function-name ;
+       ;;                          (symbol-name ;
+       ;;                           (slot-value compiler::*current-function* ;
+       ;;                                       'compiler::name)))) ;
+    (if (typep condition 'compiler::compiler-message)
+        (make-location (list :file (namestring (compiler:compiler-message-file condition)))
+                       (list :end-position (compiler:compiler-message-file-end-position condition)))
+      (list :error "No location found."))
+    )
+  )
+
+(defun handle-compiler-message (condition)
+  (unless (typep condition 'compiler::compiler-note)
+    (signal-compiler-condition
+     :original-condition condition
+     :message (princ-to-string condition)
+     :severity (etypecase condition
+                 (compiler:compiler-fatal-error :error)
+                 (compiler:compiler-error       :error)
+                 (error                  :error)
+                 (style-warning          :style-warning)
+                 (warning                :warning))
+     :location (condition-location condition))))
+
+(defimplementation call-with-compilation-hooks (function)
+  (handler-bind ((compiler:compiler-message #'handle-compiler-message))
+    (funcall function)))
+
+(defimplementation swank-compile-file (input-file output-file
+                                                  load-p external-format
+                                                  &key policy)
+  (declare (ignore policy))
+  (with-compilation-hooks ()
+    (let ((*buffer-name* nil)
+          (*compile-filename* input-file))
+      (handler-bind (#|
+                     (compiler::compiler-note
+                      #'(lambda (n)
+                          (format t "~%swank saw a compiler note: ~A~%" n) (finish-output) nil))
+                     (compiler::compiler-warning
+                      #'(lambda (w)
+                          (format t "~%swank saw a compiler warning: ~A~%" w) (finish-output) nil))
+                     (compiler::compiler-error
+                      #'(lambda (e)
+                          (format t "~%swank saw a compiler error: ~A~%" e) (finish-output) nil))
+                     |#
+                     )
+        (multiple-value-bind (output-truename warnings-p failure-p)
+             (compile-file input-file :output-file output-file :external-format external-format)
+           (values output-truename warnings-p
+                   (or failure-p
+                       (and load-p (not (load output-truename))))))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename line column policy)
+  (declare (ignore filename line column policy))
+  (with-compilation-hooks ()
+    (let ((*buffer-name* buffer)
+          (*buffer-start-position* position)
+          (*buffer-string* string))
+      (with-input-from-string (s string)
+        (when position (file-position position))
+        (compile-from-stream s)))))
+
+(defun compile-from-stream (stream)
+  (let ((file (mkcl:mkstemp "TMP:MKCL-SWANK-TMPXXXXXX"))
+        output-truename
+        warnings-p
+        failure-p
+        )
+    (with-open-file (s file :direction :output :if-exists :overwrite)
+      (do ((line (read-line stream nil) (read-line stream nil)))
+	  ((not line))
+	(write-line line s)))
+    (unwind-protect
+        (progn
+          (multiple-value-setq (output-truename warnings-p failure-p)
+               (compile-file file))
+          (and (not failure-p) (load output-truename)))
+      (when (probe-file file) (delete-file file))
+      (when (probe-file output-truename) (delete-file output-truename)))))
+
+
+;;;; Documentation
+
+(defun grovel-docstring-for-arglist (name type)
+  (flet ((compute-arglist-offset (docstring)
+           (when docstring
+             (let ((pos1 (search "Args: " docstring)))
+               (if pos1
+                   (+ pos1 6)
+                   (let ((pos2 (search "Syntax: " docstring)))
+                     (when pos2
+                       (+ pos2 8))))))))
+    (let* ((docstring (si::get-documentation name type))
+           (pos (compute-arglist-offset docstring)))
+      (if pos
+          (multiple-value-bind (arglist errorp)
+              (ignore-errors
+                (values (read-from-string docstring t nil :start pos)))
+            (if (or errorp (not (listp arglist)))
+                :not-available
+                arglist
+                ))
+          :not-available ))))
+
+(defimplementation arglist (name)
+  (cond ((and (symbolp name) (special-operator-p name))
+         (let ((arglist (grovel-docstring-for-arglist name 'function)))
+           (if (consp arglist) (cdr arglist) arglist)))
+        ((and (symbolp name) (macro-function name))
+         (let ((arglist (grovel-docstring-for-arglist name 'function)))
+           (if (consp arglist) (cdr arglist) arglist)))
+        ((or (functionp name) (fboundp name))
+         (multiple-value-bind (name fndef)
+           (if (functionp name)
+               (values (function-name name) name)
+             (values name (fdefinition name)))
+           (let ((fle (function-lambda-expression fndef)))
+             (case (car fle)
+                   (si:lambda-block (caddr fle))
+                   (t (typecase fndef
+                        (generic-function (clos::generic-function-lambda-list fndef))
+                        (compiled-function (grovel-docstring-for-arglist name 'function))
+                        (function :not-available)))))))
+        (t :not-available)))
+
+(defimplementation function-name (f)
+  (si:compiled-function-name f)
+  )
+
+(eval-when (:compile-toplevel :load-toplevel)
+  ;; At compile-time we need access to the walker package for the
+  ;; the following code to be read properly.
+  ;; It is a bit a shame we have to load the entire module to get that.
+  (require 'walker))
+
+(defimplementation macroexpand-all (form &optional env)
+  (declare (ignore env))
+  (walker:macroexpand-all form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+  (let ((result '()))
+    (dolist (type '(:VARIABLE :FUNCTION :CLASS))
+      (let ((doc (describe-definition symbol type)))
+        (when doc
+          (setf result (list* type doc result)))))
+    result))
+
+(defimplementation describe-definition (name type)
+  (case type
+    (:variable (documentation name 'variable))
+    (:function (documentation name 'function))
+    (:class (documentation name 'class))
+    (t nil)))
+
+;;; Debugging
+
+(eval-when (:compile-toplevel :load-toplevel)
+  (import
+   '(si::*break-env*
+     si::*ihs-top*
+     si::*ihs-current*
+     si::*ihs-base*
+     si::*frs-base*
+     si::*frs-top*
+     si::*tpl-commands*
+     si::*tpl-level*
+     si::frs-top
+     si::ihs-top
+     si::ihs-fun
+     si::ihs-env
+     si::sch-frs-base
+     si::set-break-env
+     si::set-current-ihs
+     si::tpl-commands)))
+
+(defvar *backtrace* '())
+
+(defun in-swank-package-p (x)
+  (and
+   (symbolp x)
+   (member (symbol-package x)
+           (list #.(find-package :swank)
+                 #.(find-package :swank/backend)
+                 #.(ignore-errors (find-package :swank-mop))
+                 #.(ignore-errors (find-package :swank-loader))))
+   t))
+
+(defun is-swank-source-p (name)
+  (setf name (pathname name))
+  #+(or)
+  (pathname-match-p
+   name
+   (make-pathname :defaults swank-loader::*source-directory*
+                  :name (pathname-name name)
+                  :type (pathname-type name)
+                  :version (pathname-version name)))
+  nil)
+
+(defun is-ignorable-fun-p (x)
+  (or
+   (in-swank-package-p (frame-name x))
+   (multiple-value-bind (file position)
+       (ignore-errors (si::compiled-function-file (car x)))
+     (declare (ignore position))
+     (if file (is-swank-source-p file)))))
+
+(defmacro find-ihs-top (x)
+  (declare (ignore x))
+  '(si::ihs-top))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+  (declare (type function debugger-loop-fn))
+  (let* (;;(*tpl-commands* si::tpl-commands)
+         (*ihs-base* 0)
+         (*ihs-top* (find-ihs-top 'call-with-debugging-environment))
+         (*ihs-current* *ihs-top*)
+         (*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top))))
+         (*frs-top* (frs-top))
+         (*read-suppress* nil)
+         ;;(*tpl-level* (1+ *tpl-level*))
+         (*backtrace* (loop for ihs from 0 below *ihs-top*
+                            collect (list (si::ihs-fun ihs)
+                                          (si::ihs-env ihs)
+                                          nil))))
+    (declare (special *ihs-current*))
+    (loop for f from *frs-base* to *frs-top*
+          do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
+               (when (plusp i)
+                 (let* ((x (elt *backtrace* i))
+                        (name (si::frs-tag f)))
+                   (unless (mkcl:fixnump name)
+                     (push name (third x)))))))
+    (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
+    (setf *tmp* *backtrace*)
+    (set-break-env)
+    (set-current-ihs)
+    (let ((*ihs-base* *ihs-top*))
+      (funcall debugger-loop-fn))))
+
+(defimplementation call-with-debugger-hook (hook fun)
+  (let ((*debugger-hook* hook)
+        (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
+    (funcall fun)))
+
+(defimplementation compute-backtrace (start end)
+  (when (numberp end)
+    (setf end (min end (length *backtrace*))))
+  (loop for f in (subseq *backtrace* start end)
+        collect f))
+
+(defimplementation format-sldb-condition (condition)
+  "Format a condition for display in SLDB."
+  ;;(princ-to-string condition)
+  (format nil "~A~%In thread: ~S" condition mt:*thread*)
+  )
+
+(defun frame-name (frame)
+  (let ((x (first frame)))
+    (if (symbolp x)
+      x
+      (function-name x))))
+
+(defun function-position (fun)
+  (multiple-value-bind (file position)
+      (si::compiled-function-file fun)
+    (and file (make-location
+               `(:file ,(if (stringp file) file (namestring file)))
+               ;;`(:position ,position)
+               `(:end-position , position)))))
+
+(defun frame-function (frame)
+  (let* ((x (first frame))
+         fun position)
+    (etypecase x
+      (symbol (and (fboundp x)
+                   (setf fun (fdefinition x)
+                         position (function-position fun))))
+      (function (setf fun x position (function-position x))))
+    (values fun position)))
+
+(defun frame-decode-env (frame)
+  (let ((functions '())
+        (blocks '())
+        (variables '()))
+    (setf frame (si::decode-ihs-env (second frame)))
+    (dolist (record frame)
+      (let* ((record0 (car record))
+	     (record1 (cdr record)))
+	(cond ((or (symbolp record0) (stringp record0))
+	       (setq variables (acons record0 record1 variables)))
+	      ((not (mkcl:fixnump record0))
+	       (push record1 functions))
+	      ((symbolp record1)
+	       (push record1 blocks))
+	      (t
+	       ))))
+    (values functions blocks variables)))
+
+(defimplementation print-frame (frame stream)
+  (let ((function (first frame)))
+    (let ((fname
+;;;           (cond ((symbolp function) function)
+;;;                 ((si:instancep function) (slot-value function 'name))
+;;;                 ((compiled-function-p function)
+;;;                  (or (si::compiled-function-name function) 'lambda))
+;;;                 (t :zombi))
+           (si::get-fname function)
+           ))
+      (if (eq fname 'si::bytecode)
+          (format stream "~A [Evaluation of: ~S]"
+                  fname (function-lambda-expression function))
+        (format stream "~A" fname)
+        )
+      (when (si::closurep function)
+        (format stream
+                ", closure generated from ~A"
+                (si::get-fname (si:closure-producer function)))
+        )
+      )
+    )
+  )
+
+(defimplementation frame-source-location (frame-number)
+  (nth-value 1 (frame-function (elt *backtrace* frame-number))))
+
+(defimplementation frame-catch-tags (frame-number)
+  (third (elt *backtrace* frame-number)))
+
+(defimplementation frame-locals (frame-number)
+  (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
+        with i = 0
+        collect (list :name name :id (prog1 i (incf i)) :value value)))
+
+(defimplementation frame-var-value (frame-number var-id)
+  (cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id)))
+
+(defimplementation disassemble-frame (frame-number)
+  (let ((fun (frame-fun (elt *backtrace* frame-number))))
+    (disassemble fun)))
+
+(defimplementation eval-in-frame (form frame-number)
+  (let ((env (second (elt *backtrace* frame-number))))
+    (si:eval-in-env form env)))
+
+#|
+(defimplementation gdb-initial-commands ()
+  ;; These signals are used by the GC.
+  #+linux '("handle SIGPWR  noprint nostop"
+            "handle SIGXCPU noprint nostop"))
+
+(defimplementation command-line-args ()
+  (loop for n from 0 below (si:argc) collect (si:argv n)))
+|#
+
+;;;; Inspector
+
+(defmethod emacs-inspect ((o t))
+  ; ecl clos support leaves some to be desired
+  (cond
+    ((streamp o)
+     (list*
+      (format nil "~S is an ordinary stream~%" o)
+      (append
+       (list
+        "Open for "
+        (cond
+          ((ignore-errors (interactive-stream-p o)) "Interactive")
+          ((and (input-stream-p o) (output-stream-p o)) "Input and output")
+          ((input-stream-p o) "Input")
+          ((output-stream-p o) "Output"))
+        `(:newline) `(:newline))
+       (label-value-line*
+        ("Element type" (stream-element-type o))
+        ("External format" (stream-external-format o)))
+       (ignore-errors (label-value-line*
+                       ("Broadcast streams" (broadcast-stream-streams o))))
+       (ignore-errors (label-value-line*
+                       ("Concatenated streams" (concatenated-stream-streams o))))
+       (ignore-errors (label-value-line*
+                       ("Echo input stream" (echo-stream-input-stream o))))
+       (ignore-errors (label-value-line*
+                       ("Echo output stream" (echo-stream-output-stream o))))
+       (ignore-errors (label-value-line*
+                       ("Output String" (get-output-stream-string o))))
+       (ignore-errors (label-value-line*
+                       ("Synonym symbol" (synonym-stream-symbol o))))
+       (ignore-errors (label-value-line*
+                       ("Input stream" (two-way-stream-input-stream o))))
+       (ignore-errors (label-value-line*
+                       ("Output stream" (two-way-stream-output-stream o)))))))
+    ((si:instancep o) ;;t
+     (let* ((cl (si:instance-class o))
+            (slots (clos::class-slots cl)))
+       (list* (format nil "~S is an instance of class ~A~%"
+                       o (clos::class-name cl))
+               (loop for x in slots append
+                    (let* ((name (clos::slot-definition-name x))
+                           (value (if (slot-boundp o name)
+                                      (clos::slot-value o name)
+                                      "Unbound"
+                                      )))
+                      (list
+                       (format nil "~S: " name)
+                       `(:value ,value)
+                       `(:newline)))))))
+    (t (list (format nil "~A" o)))))
+
+;;;; Definitions
+
+(defimplementation find-definitions (name)
+  (if (fboundp name)
+      (let ((tmp (find-source-location (symbol-function name))))
+        `(((defun ,name) ,tmp)))))
+
+(defimplementation find-source-location (obj)
+  (setf *tmp* obj)
+  (or
+   (typecase obj
+     (function
+      (multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj))
+        (if (and file pos) 
+            (make-location
+              `(:file ,(if (stringp file) file (namestring file)))
+              `(:end-position ,pos) ;; `(:position ,pos)
+              `(:snippet
+                ,(with-open-file (s file)
+                                 (file-position s pos)
+                                 (skip-comments-and-whitespace s)
+                                 (read-snippet s))))))))
+   `(:error (format nil "Source definition of ~S not found" obj))))
+
+;;;; Profiling
+
+
+(eval-when (:compile-toplevel :load-toplevel)
+  ;; At compile-time we need access to the profile package for the
+  ;; the following code to be read properly.
+  ;; It is a bit a shame we have to load the entire module to get that.
+  (require 'profile))
+
+
+(defimplementation profile (fname)
+  (when fname (eval `(profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+  (when fname (eval `(profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+  (profile:unprofile-all)
+  "All functions unprofiled.")
+
+(defimplementation profile-report ()
+  (profile:report))
+
+(defimplementation profile-reset ()
+  (profile:reset)
+  "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+  (profile:profile))
+
+(defimplementation profile-package (package callers methods)
+  (declare (ignore callers methods))
+  (eval `(profile:profile ,(package-name (find-package package)))))
+
+
+;;;; Threads
+
+(defvar *thread-id-counter* 0)
+
+(defvar *thread-id-counter-lock*
+  (mt:make-lock :name "thread id counter lock"))
+
+(defun next-thread-id ()
+  (mt:with-lock (*thread-id-counter-lock*)
+    (incf *thread-id-counter*))
+  )
+
+(defparameter *thread-id-map* (make-hash-table))
+(defparameter *id-thread-map* (make-hash-table))
+
+(defvar *thread-id-map-lock*
+  (mt:make-lock :name "thread id map lock"))
+
+(defparameter +default-thread-local-variables+
+  '(*macroexpand-hook*
+    *default-pathname-defaults*
+    *readtable*
+    *random-state*
+    *compile-print*
+    *compile-verbose*
+    *load-print*
+    *load-verbose*
+    *print-array*
+    *print-base*
+    *print-case*
+    *print-circle*
+    *print-escape*
+    *print-gensym*
+    *print-length*
+    *print-level*
+    *print-lines*
+    *print-miser-width*
+    *print-pprint-dispatch*
+    *print-pretty*
+    *print-radix*
+    *print-readably*
+    *print-right-margin*
+    *read-base*
+    *read-default-float-format*
+    *read-eval*
+    *read-suppress*
+    ))
+  
+(defun thread-local-default-bindings ()
+  (let (local)
+    (dolist (var +default-thread-local-variables+ local)
+      (setq local (acons var (symbol-value var) local))
+      )))
+
+;; mkcl doesn't have weak pointers
+(defimplementation spawn (fn &key name initial-bindings)
+  (let* ((local-defaults (thread-local-default-bindings))
+         (thread 
+          ;;(mt:make-thread :name name)
+          (mt:make-thread :name name
+                          :initial-bindings (nconc initial-bindings 
+                                                   local-defaults))
+           )
+         (id (next-thread-id)))
+    (mt:with-lock (*thread-id-map-lock*)
+      (setf (gethash id *thread-id-map*) thread)
+      (setf (gethash thread *id-thread-map*) id))
+    (mt:thread-preset
+     thread
+     #'(lambda ()
+         (unwind-protect
+              (progn
+                ;;(format t "~&Starting thread: ~S.~%" name) (finish-output)
+                (mt:thread-detach nil)
+                (funcall fn))
+           (progn
+             ;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output)
+             (mt:with-lock (*thread-id-map-lock*)
+               (remhash thread *id-thread-map*)
+               (remhash id *thread-id-map*))
+             ;;(format t "~&Finished thread: ~S~%" name) (finish-output)
+             ))))
+    (mt:thread-enable thread)
+    (mt:thread-yield)
+    thread
+    ))
+
+(defimplementation thread-id (thread)
+  (block thread-id
+    (mt:with-lock (*thread-id-map-lock*)
+      (or (gethash thread *id-thread-map*)
+          (let ((id (next-thread-id)))
+            (setf (gethash id *thread-id-map*) thread)
+            (setf (gethash thread *id-thread-map*) id)
+            id)))))
+
+(defimplementation find-thread (id)
+  (mt:with-lock (*thread-id-map-lock*)
+    (gethash id *thread-id-map*)))
+
+(defimplementation thread-name (thread)
+  (mt:thread-name thread))
+
+(defimplementation thread-status (thread)
+  (if (mt:thread-active-p thread)
+      "RUNNING"
+      "STOPPED"))
+
+(defimplementation make-lock (&key name)
+  (mt:make-lock :name name :recursive t))
+
+(defimplementation call-with-lock-held (lock function)
+  (declare (type function function))
+  (mt:with-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+  mt:*thread*)
+
+(defimplementation all-threads ()
+  (mt:all-threads))
+
+(defimplementation interrupt-thread (thread fn)
+  (mt:interrupt-thread thread fn))
+
+(defimplementation kill-thread (thread)
+  (mt:interrupt-thread thread #'mt:terminate-thread)
+  )
+
+(defimplementation thread-alive-p (thread)
+  (mt:thread-active-p thread))
+
+(defvar *mailbox-lock* (mt:make-lock :name "mailbox lock"))
+(defvar *mailboxes* (list))
+(declaim (type list *mailboxes*))
+
+(defstruct (mailbox (:conc-name mailbox.))
+  thread
+  locked-by
+  (mutex (mt:make-lock :name "thread mailbox"))
+  (semaphore (mt:make-semaphore))
+  (queue '() :type list))
+
+(defun mailbox (thread)
+  "Return THREAD's mailbox."
+  (mt:with-lock (*mailbox-lock*)
+    (or (find thread *mailboxes* :key #'mailbox.thread)
+        (let ((mb (make-mailbox :thread thread)))
+          (push mb *mailboxes*)
+          mb))))
+
+(defimplementation send (thread message)
+  (handler-case
+      (let* ((mbox (mailbox thread))
+         (mutex (mailbox.mutex mbox)))
+;;     (mt:interrupt-thread
+;;      thread
+;;      (lambda ()
+;;        (mt:with-lock (mutex)
+;;          (setf (mailbox.queue mbox)
+;;                (nconc (mailbox.queue mbox) (list message))))))
+
+;;     (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%"
+;;             mt:*thread* thread message) (finish-output)
+    (mt:with-lock (mutex)
+      (setf (mailbox.locked-by mbox) mt:*thread*)
+      (setf (mailbox.queue mbox)
+            (nconc (mailbox.queue mbox) (list message)))
+      ;;(format t "*") (finish-output)
+      (handler-case
+          (mt:semaphore-signal (mailbox.semaphore mbox))
+        (condition (condition)
+          (format t "Something went bad with semaphore-signal ~A" condition) (finish-output)
+          ;;(break)
+          ))
+      (setf (mailbox.locked-by mbox) nil)
+      )
+    ;;(format t "+") (finish-output)
+    )
+    (condition (condition)
+      (format t "~&Error in send: ~S~%" condition) (finish-output))
+    )
+  )
+
+;; (defimplementation receive ()
+;;   (block got-mail
+;;     (let* ((mbox (mailbox mt:*thread*))
+;;            (mutex (mailbox.mutex mbox)))
+;;       (loop
+;;          (mt:with-lock (mutex)
+;;            (if (mailbox.queue mbox)
+;;                (return-from got-mail (pop (mailbox.queue mbox)))))
+;;          ;;interrupt-thread will halt this if it takes longer than 1sec
+;;          (sleep 1)))))
+
+
+(defimplementation receive-if (test &optional timeout)
+  (handler-case
+  (let* ((mbox (mailbox (current-thread)))
+         (mutex (mailbox.mutex mbox))
+         got-one)
+    (assert (or (not timeout) (eq timeout t)))
+    (loop
+       (check-slime-interrupts)
+       ;;(format t "~&: ~S~%" mt:*thread*) (finish-output)
+       (handler-case
+        (setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2))
+        (condition (condition)
+           (format t "~&In (swank-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition)
+           (finish-output)
+           nil
+           )
+        )
+       (mt:with-lock (mutex)
+         (setf (mailbox.locked-by mbox) mt:*thread*)
+         (let* ((q (mailbox.queue mbox))
+                (tail (member-if test q)))
+           (when tail 
+             (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
+             (setf (mailbox.locked-by mbox) nil)
+             ;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail))
+             (return (car tail))))
+         (setf (mailbox.locked-by mbox) nil)
+         )
+
+       ;;(format t "/ ~S~%" mt:*thread*) (finish-output)
+       (when (eq timeout t) (return (values nil t)))
+;;        (unless got-one
+;;          (format t "~&In (swank-mkcl) receive-if: semaphore-wait timed out!~%"))
+       )
+    )
+    (condition (condition)
+      (format t "~&Error in (swank-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output)
+      nil
+      )
+    )
+  )
+
+
+(defmethod stream-finish-output ((stream stream))
+  (finish-output stream))
+
+
+;;
+
+;;#+windows
+(defimplementation doze-in-repl ()
+  (setq *inferior-lisp-sleeping-post* (mt:make-semaphore))
+  ;;(loop (sleep 1))
+  (mt:semaphore-wait *inferior-lisp-sleeping-post*)
+  (mk-ext:quit :verbose t)
+  )
+

sources_non_forked/slimv/slime/swank/rpc.lisp

@@ -0,0 +1,162 @@
+;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*-
+;;;
+;;; swank-rpc.lisp  -- Pass remote calls and responses between lisp systems.
+;;;
+;;; Created 2010, Terje Norderhaug <terje@in-progress.com>
+;;;
+;;; This code has been placed in the Public Domain.  All warranties
+;;; are disclaimed.
+;;;
+
+(in-package swank/rpc)
+
+
+;;;;; Input
+
+(define-condition swank-reader-error (reader-error)
+  ((packet :type string :initarg :packet 
+           :reader swank-reader-error.packet)
+   (cause :type reader-error :initarg :cause 
+          :reader swank-reader-error.cause)))
+
+(defun read-message (stream package)
+  (let ((packet (read-packet stream)))
+    (handler-case (values (read-form packet package))
+      (reader-error (c)
+        (error 'swank-reader-error 
+               :packet packet :cause c)))))
+
+(defun read-packet (stream)
+  (let* ((length (parse-header stream))
+         (octets (read-chunk stream length)))
+    (handler-case (swank/backend:utf8-to-string octets)
+      (error (c) 
+        (error 'swank-reader-error 
+               :packet (asciify octets)
+               :cause c)))))
+
+(defun asciify (packet)
+  (with-output-to-string (*standard-output*)
+    (loop for code across (etypecase packet 
+                            (string (map 'vector #'char-code packet))
+                            (vector packet))
+          do (cond ((<= code #x7f) (write-char (code-char code)))
+                   (t (format t "\\x~x" code))))))
+
+(defun parse-header (stream)
+  (parse-integer (map 'string #'code-char (read-chunk stream 6))
+                 :radix 16))
+
+(defun read-chunk (stream length)
+  (let* ((buffer (make-array length :element-type '(unsigned-byte 8)))
+         (count (read-sequence buffer stream)))
+    (cond ((= count length)
+           buffer)
+          ((zerop count)
+           (error 'end-of-file :stream stream))
+          (t
+           (error "Short read: length=~D  count=~D" length count)))))
+
+(defparameter *validate-input* nil
+  "Set to true to require input that more strictly conforms to the protocol")
+
+(defun read-form (string package)
+  (with-standard-io-syntax
+    (let ((*package* package))
+      (if *validate-input*
+          (validating-read string)
+          (read-from-string string)))))
+
+(defun validating-read (string)
+  (with-input-from-string (*standard-input* string)
+    (simple-read)))
+
+(defun simple-read ()
+   "Read a form that conforms to the protocol, otherwise signal an error."
+   (let ((c (read-char)))
+     (case c
+       (#\( (loop collect (simple-read)
+                  while (ecase (read-char)
+                          (#\) nil)
+                          (#\space t))))
+       (#\' `(quote ,(simple-read)))
+       (t
+        (cond
+          ((digit-char-p c)
+           (parse-integer
+            (map 'simple-string #'identity
+                 (loop for ch = c then (read-char nil nil)
+                       while (and ch (digit-char-p ch))
+                       collect ch
+                       finally (unread-char ch)))))
+          ((or (member c '(#\: #\")) (alpha-char-p c))
+           (unread-char c)
+           (read-preserving-whitespace))
+          (t (error "Invalid character ~:c" c)))))))
+
+
+;;;;; Output
+
+(defun write-message (message package stream)
+  (let* ((string (prin1-to-string-for-emacs message package))
+         (octets (handler-case (swank/backend:string-to-utf8 string)
+                   (error (c) (encoding-error c string))))
+         (length (length octets)))
+    (write-header stream length)
+    (write-sequence octets stream)
+    (finish-output stream)))
+
+;; FIXME: for now just tell emacs that we and an encoding problem.
+(defun encoding-error (condition string)
+  (swank/backend:string-to-utf8
+   (prin1-to-string-for-emacs
+    `(:reader-error
+      ,(asciify string)
+      ,(format nil "Error during string-to-utf8: ~a"
+               (or (ignore-errors (asciify (princ-to-string condition)))
+                   (asciify (princ-to-string (type-of condition))))))
+    (find-package :cl))))
+
+(defun write-header (stream length)
+  (declare (type (unsigned-byte 24) length))
+  ;;(format *trace-output* "length: ~d (#x~x)~%" length length)
+  (loop for c across (format nil "~6,'0x" length)
+        do (write-byte (char-code c) stream)))
+
+(defun switch-to-double-floats (x)
+  (typecase x
+    (double-float x)
+    (float (coerce x 'double-float))
+    (null x)
+    (list (loop for (x . cdr) on x
+                collect (switch-to-double-floats x) into result
+                until (atom cdr)
+                finally (return (append result (switch-to-double-floats cdr)))))
+    (t x)))
+
+(defun prin1-to-string-for-emacs (object package)
+  (with-standard-io-syntax
+    (let ((*print-case* :downcase)
+          (*print-readably* nil)
+          (*print-pretty* nil)
+          (*package* package)
+          ;; Emacs has only double floats.
+          (*read-default-float-format* 'double-float))
+      (prin1-to-string (switch-to-double-floats object)))))
+
+
+#| TEST/DEMO:
+
+(defparameter *transport*
+  (with-output-to-string (out)
+    (write-message '(:message (hello "world")) *package* out)
+    (write-message '(:return 5) *package* out)
+    (write-message '(:emacs-rex NIL) *package* out)))
+
+*transport*
+                 
+(with-input-from-string (in *transport*)
+  (loop while (peek-char T in NIL)
+        collect (read-message in *package*)))
+
+|#

sources_non_forked/slimv/slime/swank/source-file-cache.lisp

@@ -0,0 +1,136 @@
+;;;; Source-file cache
+;;;
+;;; To robustly find source locations in CMUCL and SBCL it's useful to
+;;; have the exact source code that the loaded code was compiled from.
+;;; In this source we can accurately find the right location, and from
+;;; that location we can extract a "snippet" of code to show what the
+;;; definition looks like. Emacs can use this snippet in a best-match
+;;; search to locate the right definition, which works well even if
+;;; the buffer has been modified.
+;;;
+;;; The idea is that if a definition previously started with
+;;; `(define-foo bar' then it probably still does.
+;;;
+;;; Whenever we see that the file on disk has the same
+;;; `file-write-date' as a location we're looking for we cache the
+;;; whole file inside Lisp. That way we will still have the matching
+;;; version even if the file is later modified on disk. If the file is
+;;; later recompiled and reloaded then we replace our cache entry.
+;;;
+;;; This code has been placed in the Public Domain.  All warranties
+;;; are disclaimed.
+
+(defpackage swank/source-file-cache
+  (:use cl)
+  (:import-from swank/backend
+		defimplementation buffer-first-change
+		guess-external-format
+		find-external-format)
+  (:export
+   get-source-code
+   source-cache-get ;FIXME: isn't it odd that both are exported?
+
+   *source-snippet-size*
+   read-snippet
+   read-snippet-from-string
+   ))
+
+(in-package swank/source-file-cache)
+
+(defvar *cache-sourcecode* t
+  "When true complete source files are cached.
+The cache is used to keep known good copies of the source text which
+correspond to the loaded code. Finding definitions is much more
+reliable when the exact source is available, so we cache it in case it
+gets edited on disk later.")
+
+(defvar *source-file-cache* (make-hash-table :test 'equal)
+  "Cache of source file contents.
+Maps from truename to source-cache-entry structure.")
+
+(defstruct (source-cache-entry
+             (:conc-name source-cache-entry.)
+             (:constructor make-source-cache-entry (text date)))
+  text date)
+
+(defimplementation buffer-first-change (filename)
+  "Load a file into the cache when the user modifies its buffer.
+This is a win if the user then saves the file and tries to M-. into it."
+  (unless (source-cached-p filename)
+    (ignore-errors
+      (source-cache-get filename (file-write-date filename))))
+  nil)
+
+(defun get-source-code (filename code-date)
+  "Return the source code for FILENAME as written on DATE in a string.
+If the exact version cannot be found then return the current one from disk."
+  (or (source-cache-get filename code-date)
+      (read-file filename)))
+
+(defun source-cache-get (filename date)
+  "Return the source code for FILENAME as written on DATE in a string.
+Return NIL if the right version cannot be found."
+  (when *cache-sourcecode*
+    (let ((entry (gethash filename *source-file-cache*)))
+      (cond ((and entry (equal date (source-cache-entry.date entry)))
+             ;; Cache hit.
+             (source-cache-entry.text entry))
+            ((or (null entry)
+                 (not (equal date (source-cache-entry.date entry))))
+             ;; Cache miss.
+             (if (equal (file-write-date filename) date)
+                 ;; File on disk has the correct version.
+                 (let ((source (read-file filename)))
+                   (setf (gethash filename *source-file-cache*)
+                         (make-source-cache-entry source date))
+                   source)
+                 nil))))))
+
+(defun source-cached-p (filename)
+  "Is any version of FILENAME in the source cache?"
+  (if (gethash filename *source-file-cache*) t))
+
+(defun read-file (filename)
+  "Return the entire contents of FILENAME as a string."
+  (with-open-file (s filename :direction :input
+		     :external-format (or (guess-external-format filename)
+					  (find-external-format "latin-1")
+					  :default))
+    (let* ((string (make-string (file-length s)))
+           (length (read-sequence string s)))
+      (subseq string 0 length))))
+
+;;;; Snippets
+
+(defvar *source-snippet-size* 256
+  "Maximum number of characters in a snippet of source code.
+Snippets at the beginning of definitions are used to tell Emacs what
+the definitions looks like, so that it can accurately find them by
+text search.")
+
+(defun read-snippet (stream &optional position)
+  "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM.
+If POSITION is given, set the STREAM's file position first."
+  (when position
+    (file-position stream position))
+  #+sbcl (skip-comments-and-whitespace stream)
+  (read-upto-n-chars stream *source-snippet-size*))
+
+(defun read-snippet-from-string (string &optional position)
+  (with-input-from-string (s string)
+    (read-snippet s position)))
+
+(defun skip-comments-and-whitespace (stream)
+  (case (peek-char nil stream nil nil)
+    ((#\Space #\Tab #\Newline #\Linefeed #\Page)
+     (read-char stream)
+     (skip-comments-and-whitespace stream))
+    (#\;
+     (read-line stream)
+     (skip-comments-and-whitespace stream))))
+
+(defun read-upto-n-chars (stream n)
+  "Return a string of upto N chars from STREAM."
+  (let* ((string (make-string n))
+         (chars  (read-sequence string stream)))
+    (subseq string 0 chars)))

sources_non_forked/slimv/slime/swank/source-path-parser.lisp

@@ -0,0 +1,242 @@
+;;;; Source-paths
+
+;;; CMUCL/SBCL use a data structure called "source-path" to locate
+;;; subforms.  The compiler assigns a source-path to each form in a
+;;; compilation unit.  Compiler notes usually contain the source-path
+;;; of the error location.
+;;;
+;;; Compiled code objects don't contain source paths, only the
+;;; "toplevel-form-number" and the (sub-) "form-number".  To get from
+;;; the form-number to the source-path we need the entire toplevel-form
+;;; (i.e. we have to read the source code).  CMUCL has already some
+;;; utilities to do this translation, but we use some extended
+;;; versions, because we need more exact position info.  Apparently
+;;; Hemlock is happy with the position of the toplevel-form; we also
+;;; need the position of subforms.
+;;;
+;;; We use a special readtable to get the positions of the subforms.
+;;; The readtable stores the start and end position for each subform in
+;;; hashtable for later retrieval.
+;;;
+;;; This code has been placed in the Public Domain.  All warranties
+;;; are disclaimed.
+
+;;; Taken from swank-cmucl.lisp, by Helmut Eller
+
+(defpackage swank/source-path-parser
+  (:use cl)
+  (:export
+   read-source-form
+   source-path-string-position
+   source-path-file-position
+   source-path-source-position
+
+   sexp-in-bounds-p
+   sexp-ref)
+  (:shadow ignore-errors))
+
+(in-package swank/source-path-parser)
+
+;; Some test to ensure the required conformance
+(let ((rt (copy-readtable nil)))
+  (assert (or (not (get-macro-character #\space rt))
+	      (nth-value 1 (get-macro-character #\space rt))))
+  (assert (not (get-macro-character #\\ rt))))
+
+(eval-when (:compile-toplevel)
+  (defmacro ignore-errors (&rest forms)
+    ;;`(progn . ,forms) ; for debugging
+    `(cl:ignore-errors . ,forms)))
+
+(defun make-sharpdot-reader (orig-sharpdot-reader)
+  (lambda (s c n)
+    ;; We want things like M-. to work regardless of any #.-fu in
+    ;; the source file that is to be visited. (For instance, when a
+    ;; file contains #. forms referencing constants that do not
+    ;; currently exist in the image.)
+    (ignore-errors (funcall orig-sharpdot-reader s c n))))
+
+(defun make-source-recorder (fn source-map)
+  "Return a macro character function that does the same as FN, but
+additionally stores the result together with the stream positions
+before and after of calling FN in the hashtable SOURCE-MAP."
+  (lambda (stream char)
+    (let ((start (1- (file-position stream)))
+	  (values (multiple-value-list (funcall fn stream char)))
+	  (end (file-position stream)))
+      #+(or)
+      (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%"
+	      start values end (char-code char) char)
+      (when values
+        (destructuring-bind (&optional existing-start &rest existing-end)
+            (car (gethash (car values) source-map))
+          ;; Some macros may return what a sub-call to another macro
+          ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice,
+          ;; once from #\# and once from #\(. If the saved form
+          ;; is a subform, don't save it again.
+          (unless (and existing-start existing-end
+                       (<= start existing-start end)
+                       (<= start existing-end end))
+            (push (cons start end) (gethash (car values) source-map)))))
+      (values-list values))))
+
+(defun make-source-recording-readtable (readtable source-map)
+  (declare (type readtable readtable) (type hash-table source-map))
+  "Return a source position recording copy of READTABLE.
+The source locations are stored in SOURCE-MAP."
+  (flet ((install-special-sharpdot-reader (rt)
+	   (let ((fun (ignore-errors
+			(get-dispatch-macro-character #\# #\. rt))))
+	     (when fun
+	       (let ((wrapper (make-sharpdot-reader fun)))
+		 (set-dispatch-macro-character #\# #\. wrapper rt)))))
+	 (install-wrappers (rt)
+	   (dotimes (code 128)
+	     (let ((char (code-char code)))
+	       (multiple-value-bind (fun nt) (get-macro-character char rt)
+		 (when fun
+		   (let ((wrapper (make-source-recorder fun source-map)))
+		     (set-macro-character char wrapper nt rt))))))))
+    (let ((rt (copy-readtable readtable)))
+      (install-special-sharpdot-reader rt)
+      (install-wrappers rt)
+      rt)))
+
+;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning.
+;; Should be possible as we only need the right "list structure" and
+;; not the right atoms.
+(defun read-and-record-source-map (stream)
+  "Read the next object from STREAM.
+Return the object together with a hashtable that maps
+subexpressions of the object to stream positions."
+  (let* ((source-map (make-hash-table :test #'eq))
+         (*readtable* (make-source-recording-readtable *readtable* source-map))
+	 (*read-suppress* nil)
+	 (start (file-position stream))
+	 (form (ignore-errors (read stream)))
+	 (end (file-position stream)))
+    ;; ensure that at least FORM is in the source-map
+    (unless (gethash form source-map)
+      (push (cons start end) (gethash form source-map)))
+    (values form source-map)))
+
+(defun starts-with-p (string prefix)
+  (declare (type string string prefix))
+  (not (mismatch string prefix
+		 :end1 (min (length string) (length prefix))
+		 :test #'char-equal)))
+
+(defun extract-package (line)
+  (declare (type string line))
+  (let ((name (cadr (read-from-string line))))
+    (find-package name)))
+
+#+(or)
+(progn
+  (assert (extract-package "(in-package cl)"))
+  (assert (extract-package "(cl:in-package cl)"))
+  (assert (extract-package "(in-package \"CL\")"))
+  (assert (extract-package "(in-package #:cl)")))
+
+;; FIXME: do something cleaner than this.
+(defun readtable-for-package (package)
+  ;; KLUDGE: due to the load order we can't reference the swank
+  ;; package.
+  (funcall (read-from-string "swank::guess-buffer-readtable")
+           (string-upcase (package-name package))))
+
+;; Search STREAM for a "(in-package ...)" form.  Use that to derive
+;; the values for *PACKAGE* and *READTABLE*.
+;;
+;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends
+;; use the same heuristic and to avoid the need to access
+;; swank::guess-buffer-readtable from here.
+(defun guess-reader-state (stream)
+  (let* ((point (file-position stream))
+	 (pkg *package*))
+    (file-position stream 0)
+    (loop for line = (read-line stream nil nil) do
+	  (when (not line) (return))
+	  (when (or (starts-with-p line "(in-package ")
+		    (starts-with-p line "(cl:in-package "))
+	    (let ((p (extract-package line)))
+	      (when p (setf pkg p)))
+	    (return)))
+    (file-position stream point)
+    (values (readtable-for-package pkg) pkg)))
+
+(defun skip-whitespace (stream)
+  (peek-char t stream nil nil))
+
+;; Skip over N toplevel forms.
+(defun skip-toplevel-forms (n stream)
+  (let ((*read-suppress* t))
+    (dotimes (i n)
+      (read stream))
+    (skip-whitespace stream)))
+
+(defun read-source-form (n stream)
+  "Read the Nth toplevel form number with source location recording.
+Return the form and the source-map."
+  (multiple-value-bind (*readtable* *package*) (guess-reader-state stream)
+    (let (#+sbcl
+          (*features* (append *features*
+                              (symbol-value (find-symbol "+INTERNAL-FEATURES+" 'sb-impl)))))
+      (skip-toplevel-forms n stream)
+      (read-and-record-source-map stream))))
+
+(defun source-path-stream-position (path stream)
+  "Search the source-path PATH in STREAM and return its position."
+  (check-source-path path)
+  (destructuring-bind (tlf-number . path) path
+    (multiple-value-bind (form source-map) (read-source-form tlf-number stream)
+      (source-path-source-position (cons 0 path) form source-map))))
+
+(defun check-source-path (path)
+  (unless (and (consp path)
+               (every #'integerp path))
+    (error "The source-path ~S is not valid." path)))
+
+(defun source-path-string-position (path string)
+  (with-input-from-string (s string)
+    (source-path-stream-position path s)))
+
+(defun source-path-file-position (path filename)
+  ;; We go this long way round, and don't directly operate on the file
+  ;; stream because FILE-POSITION (used above) is not totally savy even
+  ;; on file character streams; on SBCL, FILE-POSITION returns the binary
+  ;; offset, and not the character offset---screwing up on Unicode.
+  (let ((toplevel-number (first path))
+	(buffer))
+    (with-open-file (file filename)
+      (skip-toplevel-forms (1+ toplevel-number) file)
+      (let ((endpos (file-position file)))
+	(setq buffer (make-array (list endpos) :element-type 'character
+				 :initial-element #\Space))
+	(assert (file-position file 0))
+	(read-sequence buffer file :end endpos)))
+    (source-path-string-position path buffer)))
+
+(defgeneric sexp-in-bounds-p (sexp i)
+  (:method ((list list) i)
+    (< i (loop for e on list
+               count t)))
+  (:method ((sexp t) i) nil))
+
+(defgeneric sexp-ref (sexp i)
+  (:method ((s list) i) (elt s i)))
+
+(defun source-path-source-position (path form source-map)
+  "Return the start position of PATH from FORM and SOURCE-MAP.  All
+subforms along the path are considered and the start and end position
+of the deepest (i.e. smallest) possible form is returned."
+  ;; compute all subforms along path
+  (let ((forms (loop for i in path
+		     for f = form then (if (sexp-in-bounds-p f i)
+					   (sexp-ref f i))
+		     collect f)))
+    ;; select the first subform present in source-map
+    (loop for form in (nreverse forms)
+	  for ((start . end) . rest) = (gethash form source-map)
+	  when (and start end (not rest))
+	  return (return (values start end)))))