sbcl stuff

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/.boring

@@ -0,0 +1,13 @@
+# Boring file regexps:
+~$
+^_darcs
+^\{arch\}
+^.arch-ids
+\#
+\.dfsl$
+\.ppcf$
+\.fasl$
+\.x86f$
+\.fas$
+\.lib$
+^public_html

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/.gitignore

@@ -0,0 +1,4 @@
+*.fasl
+*~
+\#*
+*.patch

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/AUTHORS

@@ -0,0 +1,9 @@
+
+ACTA EST FABULA PLAUDITE
+
+Nikodemus Siivola 
+Attila Lendvai
+Marco Baringer
+Robert Strandh
+Luis Oliveira
+Tobias C. Rittweiler

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/LICENCE

@@ -0,0 +1,37 @@
+Alexandria software and associated documentation are in the public
+domain:
+
+  Authors dedicate this work to public domain, for the benefit of the
+  public at large and to the detriment of the authors' heirs and
+  successors. Authors intends this dedication to be an overt act of
+  relinquishment in perpetuity of all present and future rights under
+  copyright law, whether vested or contingent, in the work. Authors
+  understands that such relinquishment of all rights includes the
+  relinquishment of all rights to enforce (by lawsuit or otherwise)
+  those copyrights in the work.
+
+  Authors recognize that, once placed in the public domain, the work
+  may be freely reproduced, distributed, transmitted, used, modified,
+  built upon, or otherwise exploited by anyone for any purpose,
+  commercial or non-commercial, and in any way, including by methods
+  that have not yet been invented or conceived.
+
+In those legislations where public domain dedications are not
+recognized or possible, Alexandria is distributed under the following
+terms and conditions:
+
+  Permission is hereby granted, free of charge, to any person
+  obtaining a copy of this software and associated documentation files
+  (the "Software"), to deal in the Software without restriction,
+  including without limitation the rights to use, copy, modify, merge,
+  publish, distribute, sublicense, and/or sell copies of the Software,
+  and to permit persons to whom the Software is furnished to do so,
+  subject to the following conditions:
+
+  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/README

@@ -0,0 +1,52 @@
+Alexandria is a collection of portable public domain utilities that
+meet the following constraints:
+
+ * Utilities, not extensions: Alexandria will not contain conceptual
+   extensions to Common Lisp, instead limiting itself to tools and
+   utilities that fit well within the framework of standard ANSI
+   Common Lisp. Test-frameworks, system definitions, logging
+   facilities, serialization layers, etc. are all outside the scope of
+   Alexandria as a library, though well within the scope of Alexandria
+   as a project.
+
+ * Conservative: Alexandria limits itself to what project members
+   consider conservative utilities. Alexandria does not and will not
+   include anaphoric constructs, loop-like binding macros, etc.
+
+ * Portable: Alexandria limits itself to portable parts of Common
+   Lisp. Even apparently conservative and useful functions remain
+   outside the scope of Alexandria if they cannot be implemented
+   portably. Portability is here defined as portable within a
+   conforming implementation: implementation bugs are not considered
+   portability issues.
+
+Homepage:
+
+  http://common-lisp.net/project/alexandria/
+
+Mailing lists:
+
+  http://lists.common-lisp.net/mailman/listinfo/alexandria-devel
+  http://lists.common-lisp.net/mailman/listinfo/alexandria-cvs
+
+Repository:
+
+  git://common-lisp.net/projects/alexandria/alexandria.git
+
+Documentation:
+
+  http://common-lisp.net/project/alexandria/draft/alexandria.html
+
+  (To build docs locally: cd doc && make html pdf info)
+
+Patches:
+
+  Patches are always welcome! Please send them to the mailing list as
+  attachments, generated by "git format-patch -1".
+
+  Patches should include a commit message that explains what's being
+  done and /why/, and when fixing a bug or adding a feature you should
+  also include a test-case.
+
+  Be advised though that right now new features are unlikely to be
+  accepted until 1.0 is officially out of the door.

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/alexandria-tests.asd

@@ -0,0 +1,11 @@
+(defsystem "alexandria-tests"
+  :licence "Public Domain / 0-clause MIT"
+  :description "Tests for Alexandria, which is a collection of portable public domain utilities."
+  :author "Nikodemus Siivola <nikodemus@sb-studio.net>, and others."
+  :depends-on (:alexandria #+sbcl :sb-rt #-sbcl :rt)
+  :components ((:file "tests"))
+  :perform (test-op (o c)
+             (flet ((run-tests (&rest args)
+                      (apply (intern (string '#:run-tests) '#:alexandria-tests) args)))
+               (run-tests :compiled nil)
+               (run-tests :compiled t))))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/alexandria.asd

@@ -0,0 +1,62 @@
+(defsystem "alexandria"
+  :version "1.0.0"
+  :licence "Public Domain / 0-clause MIT"
+  :description "Alexandria is a collection of portable public domain utilities."
+  :author "Nikodemus Siivola and others."
+  :long-description
+  "Alexandria is a project and a library.
+
+As a project Alexandria's goal is to reduce duplication of effort and improve
+portability of Common Lisp code according to its own idiosyncratic and rather
+conservative aesthetic.
+
+As a library Alexandria is one of the means by which the project strives for
+its goals.
+
+Alexandria is a collection of portable public domain utilities that meet
+the following constraints:
+
+ * Utilities, not extensions: Alexandria will not contain conceptual
+   extensions to Common Lisp, instead limiting itself to tools and utilities
+   that fit well within the framework of standard ANSI Common Lisp.
+   Test-frameworks, system definitions, logging facilities, serialization
+   layers, etc. are all outside the scope of Alexandria as a library, though
+   well within the scope of Alexandria as a project.
+
+ * Conservative: Alexandria limits itself to what project members consider
+   conservative utilities. Alexandria does not and will not include anaphoric
+   constructs, loop-like binding macros, etc.
+   Also, its exported symbols are being imported by many other packages
+   already, so each new export carries the danger of causing conflicts.
+
+ * Portable: Alexandria limits itself to portable parts of Common Lisp. Even
+   apparently conservative and useful functions remain outside the scope of
+   Alexandria if they cannot be implemented portably. Portability is here
+   defined as portable within a conforming implementation: implementation bugs
+   are not considered portability issues.
+
+ * Team player: Alexandria will not (initially, at least) subsume or provide
+   functionality for which good-quality special-purpose packages exist, like
+   split-sequence. Instead, third party packages such as that may be
+   \"blessed\"."
+  :components
+  ((:static-file "LICENCE")
+   (:static-file "tests.lisp")
+   (:file "package")
+   (:file "definitions" :depends-on ("package"))
+   (:file "binding" :depends-on ("package"))
+   (:file "strings" :depends-on ("package"))
+   (:file "conditions" :depends-on ("package"))
+   (:file "io" :depends-on ("package" "macros" "lists" "types"))
+   (:file "macros" :depends-on ("package" "strings" "symbols"))
+   (:file "hash-tables" :depends-on ("package" "macros"))
+   (:file "control-flow" :depends-on ("package" "definitions" "macros"))
+   (:file "symbols" :depends-on ("package"))
+   (:file "functions" :depends-on ("package" "symbols" "macros"))
+   (:file "lists" :depends-on ("package" "functions"))
+   (:file "types" :depends-on ("package" "symbols" "lists"))
+   (:file "arrays" :depends-on ("package" "types"))
+   (:file "sequences" :depends-on ("package" "lists" "types"))
+   (:file "numbers" :depends-on ("package" "sequences"))
+   (:file "features" :depends-on ("package" "control-flow")))
+  :in-order-to ((test-op (test-op "alexandria-tests"))))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/arrays.lisp

@@ -0,0 +1,18 @@
+(in-package :alexandria)
+
+(defun copy-array (array &key (element-type (array-element-type array))
+                              (fill-pointer (and (array-has-fill-pointer-p array)
+                                                 (fill-pointer array)))
+                              (adjustable (adjustable-array-p array)))
+  "Returns an undisplaced copy of ARRAY, with same fill-pointer and
+adjustability (if any) as the original, unless overridden by the keyword
+arguments."
+ (let* ((dimensions (array-dimensions array))
+        (new-array (make-array dimensions
+                               :element-type element-type
+                               :adjustable adjustable
+                               :fill-pointer fill-pointer)))
+   (dotimes (i (array-total-size array))
+     (setf (row-major-aref new-array i)
+           (row-major-aref array i)))
+   new-array))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/binding.lisp

@@ -0,0 +1,90 @@
+(in-package :alexandria)
+
+(defmacro if-let (bindings &body (then-form &optional else-form))
+    "Creates new variable bindings, and conditionally executes either
+THEN-FORM or ELSE-FORM. ELSE-FORM defaults to NIL.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+  (variable-2 initial-form-2)
+  ...
+  (variable-n initial-form-n))
+
+All initial-forms are executed sequentially in the specified order. Then all
+the variables are bound to the corresponding values.
+
+If all variables were bound to true values, the THEN-FORM is executed with the
+bindings in effect, otherwise the ELSE-FORM is executed with the bindings in
+effect."
+    (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                             (list bindings)
+                             bindings))
+         (variables (mapcar #'car binding-list)))
+    `(let ,binding-list
+       (if (and ,@variables)
+           ,then-form
+           ,else-form))))
+
+(defmacro when-let (bindings &body forms)
+    "Creates new variable bindings, and conditionally executes FORMS.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+  (variable-2 initial-form-2)
+  ...
+  (variable-n initial-form-n))
+
+All initial-forms are executed sequentially in the specified order. Then all
+the variables are bound to the corresponding values.
+
+If all variables were bound to true values, then FORMS are executed as an
+implicit PROGN."
+  (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                           (list bindings)
+                           bindings))
+         (variables (mapcar #'car binding-list)))
+    `(let ,binding-list
+       (when (and ,@variables)
+         ,@forms))))
+
+(defmacro when-let* (bindings &body body)
+  "Creates new variable bindings, and conditionally executes BODY.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+  (variable-2 initial-form-2)
+  ...
+  (variable-n initial-form-n))
+
+Each INITIAL-FORM is executed in turn, and the variable bound to the
+corresponding value. INITIAL-FORM expressions can refer to variables
+previously bound by the WHEN-LET*.
+
+Execution of WHEN-LET* stops immediately if any INITIAL-FORM evaluates to NIL.
+If all INITIAL-FORMs evaluate to true, then BODY is executed as an implicit
+PROGN."
+  (let ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                          (list bindings)
+                          bindings)))
+    (labels ((bind (bindings body)
+               (if bindings
+                   `(let (,(car bindings))
+                      (when ,(caar bindings)
+                        ,(bind (cdr bindings) body)))
+                   `(progn ,@body))))
+      (bind binding-list body))))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/conditions.lisp

@@ -0,0 +1,91 @@
+(in-package :alexandria)
+
+(defun required-argument (&optional name)
+  "Signals an error for a missing argument of NAME. Intended for
+use as an initialization form for structure and class-slots, and
+a default value for required keyword arguments."
+  (error "Required argument ~@[~S ~]missing." name))
+
+(define-condition simple-style-warning (simple-warning style-warning)
+  ())
+
+(defun simple-style-warning (message &rest args)
+  (warn 'simple-style-warning :format-control message :format-arguments args))
+
+;; We don't specify a :report for simple-reader-error to let the
+;; underlying implementation report the line and column position for
+;; us. Unfortunately this way the message from simple-error is not
+;; displayed, unless there's special support for that in the
+;; implementation. But even then it's still inspectable from the
+;; debugger...
+(define-condition simple-reader-error
+    #-sbcl(simple-error reader-error)
+    #+sbcl(sb-int:simple-reader-error)
+  ())
+
+(defun simple-reader-error (stream message &rest args)
+  (error 'simple-reader-error
+         :stream stream
+         :format-control message
+         :format-arguments args))
+
+(define-condition simple-parse-error (simple-error parse-error)
+  ())
+
+(defun simple-parse-error (message &rest args)
+  (error 'simple-parse-error
+         :format-control message
+         :format-arguments args))
+
+(define-condition simple-program-error (simple-error program-error)
+  ())
+
+(defun simple-program-error (message &rest args)
+  (error 'simple-program-error
+         :format-control message
+         :format-arguments args))
+
+(defmacro ignore-some-conditions ((&rest conditions) &body body)
+  "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
+list determines which specific conditions are to be ignored."
+  `(handler-case
+       (progn ,@body)
+     ,@(loop for condition in conditions collect
+             `(,condition (c) (values nil c)))))
+
+(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
+  "Like CL:UNWIND-PROTECT, but you can specify the circumstances that
+the cleanup CLAUSES are run.
+
+  clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*
+
+Clauses can be given in any order, and more than one clause can be
+given for each circumstance. The clauses whose denoted circumstance
+occured, are executed in the order the clauses appear.
+
+ABORT-FLAG is the name of a variable that will be bound to T in
+CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
+otherwise.
+
+Examples:
+
+  (unwind-protect-case ()
+       (protected-form)
+     (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
+     (:abort  (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
+     (:always (format t \"This is evaluated in either case.~%\")))
+
+  (unwind-protect-case (aborted-p)
+       (protected-form)
+     (:always (perform-cleanup-if aborted-p)))
+"
+  (check-type abort-flag (or null symbol))
+  (let ((gflag (gensym "FLAG+")))
+    `(let ((,gflag t))
+       (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
+	 (let ,(and abort-flag `((,abort-flag ,gflag)))
+	   ,@(loop for (cleanup-kind . forms) in clauses
+		   collect (ecase cleanup-kind
+			     (:normal `(when (not ,gflag) ,@forms))
+			     (:abort  `(when ,gflag ,@forms))
+			     (:always `(progn ,@forms)))))))))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/control-flow.lisp

@@ -0,0 +1,106 @@
+(in-package :alexandria)
+
+(defun extract-function-name (spec)
+  "Useful for macros that want to mimic the functional interface for functions
+like #'eq and 'eq."
+  (if (and (consp spec)
+           (member (first spec) '(quote function)))
+      (second spec)
+      spec))
+
+(defun generate-switch-body (whole object clauses test key &optional default)
+  (with-gensyms (value)
+    (setf test (extract-function-name test))
+    (setf key (extract-function-name key))
+    (when (and (consp default)
+               (member (first default) '(error cerror)))
+      (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
+                      ,value ',test)))
+    `(let ((,value (,key ,object)))
+      (cond ,@(mapcar (lambda (clause)
+                        (if (member (first clause) '(t otherwise))
+                            (progn
+                              (when default
+                                (error "Multiple default clauses or illegal use of a default clause in ~S."
+                                       whole))
+                              (setf default `(progn ,@(rest clause)))
+                              '(()))
+                            (destructuring-bind (key-form &body forms) clause
+                              `((,test ,value ,key-form)
+                                ,@forms))))
+                      clauses)
+            (t ,default)))))
+
+(defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
+                         &body clauses)
+  "Evaluates first matching clause, returning its values, or evaluates and
+returns the values of T or OTHERWISE if no keys match."
+  (generate-switch-body whole object clauses test key))
+
+(defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
+                          &body clauses)
+  "Like SWITCH, but signals an error if no key matches."
+  (generate-switch-body whole object clauses test key '(error)))
+
+(defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
+                          &body clauses)
+  "Like SWITCH, but signals a continuable error if no key matches."
+  (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
+
+(defmacro whichever (&rest possibilities &environment env)
+  "Evaluates exactly one of POSSIBILITIES, chosen at random."
+  (setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities))
+  (if (every (lambda (p) (constantp p)) possibilities)
+      `(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities)))
+      (labels ((expand (possibilities position random-number)
+                 (if (null (cdr possibilities))
+                     (car possibilities)
+                     (let* ((length (length possibilities))
+                            (half (truncate length 2))
+                            (second-half (nthcdr half possibilities))
+                            (first-half (butlast possibilities (- length half))))
+                       `(if (< ,random-number ,(+ position half))
+                            ,(expand first-half position random-number)
+                            ,(expand second-half (+ position half) random-number))))))
+        (with-gensyms (random-number)
+          (let ((length (length possibilities)))
+            `(let ((,random-number (random ,length)))
+               ,(expand possibilities 0 random-number)))))))
+
+(defmacro xor (&rest datums)
+  "Evaluates its arguments one at a time, from left to right. If more than one
+argument evaluates to a true value no further DATUMS are evaluated, and NIL is
+returned as both primary and secondary value. If exactly one argument
+evaluates to true, its value is returned as the primary value after all the
+arguments have been evaluated, and T is returned as the secondary value. If no
+arguments evaluate to true NIL is retuned as primary, and T as secondary
+value."
+  (with-gensyms (xor tmp true)
+    `(let (,tmp ,true)
+       (block ,xor
+         ,@(mapcar (lambda (datum)
+                     `(if (setf ,tmp ,datum)
+                          (if ,true
+                              (return-from ,xor (values nil nil))
+                              (setf ,true ,tmp))))
+                   datums)
+         (return-from ,xor (values ,true t))))))
+
+(defmacro nth-value-or (nth-value &body forms)
+  "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one
+of the forms is true. It then returns all the values returned by evaluating
+that form. If none of the forms return a true nth value, this form returns
+NIL."
+  (once-only (nth-value)
+    (with-gensyms (values)
+      `(let ((,values (multiple-value-list ,(first forms))))
+         (if (nth ,nth-value ,values)
+             (values-list ,values)
+             ,(if (rest forms)
+                  `(nth-value-or ,nth-value ,@(rest forms))
+                  nil))))))
+
+(defmacro multiple-value-prog2 (first-form second-form &body forms)
+  "Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its value
+all the value returned by SECOND-FORM."
+  `(progn ,first-form (multiple-value-prog1 ,second-form ,@forms)))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/definitions.lisp

@@ -0,0 +1,37 @@
+(in-package :alexandria)
+
+(defun %reevaluate-constant (name value test)
+  (if (not (boundp name))
+      value
+      (let ((old (symbol-value name))
+            (new value))
+        (if (not (constantp name))
+            (prog1 new
+              (cerror "Try to redefine the variable as a constant."
+                      "~@<~S is an already bound non-constant variable ~
+                       whose value is ~S.~:@>" name old))
+            (if (funcall test old new)
+                old
+                (restart-case
+                    (error "~@<~S is an already defined constant whose value ~
+                              ~S is not equal to the provided initial value ~S ~
+                              under ~S.~:@>" name old new test)
+                  (ignore ()
+                    :report "Retain the current value."
+                    old)
+                  (continue ()
+                    :report "Try to redefine the constant."
+                    new)))))))
+
+(defmacro define-constant (name initial-value &key (test ''eql) documentation)
+  "Ensures that the global variable named by NAME is a constant with a value
+that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a
+/function designator/ that defaults to EQL. If DOCUMENTATION is given, it
+becomes the documentation string of the constant.
+
+Signals an error if NAME is already a bound non-constant variable.
+
+Signals an error if NAME is already a constant variable whose value is not
+equal under TEST to result of evaluating INITIAL-VALUE."
+  `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
+     ,@(when documentation `(,documentation))))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/.gitignore

@@ -0,0 +1,3 @@
+alexandria
+include
+

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/Makefile

@@ -0,0 +1,28 @@
+.PHONY: clean html pdf include clean-include clean-crap info doc
+
+doc: pdf html info clean-crap
+
+clean-include:
+	rm -rf include
+
+clean-crap:
+	rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr
+
+clean: clean-include
+	rm -f  *.pdf *.html *.info
+
+include:
+	sbcl --no-userinit --eval '(require :asdf)' \
+	--eval '(let ((asdf:*central-registry* (list "../"))) (require :alexandria))' \
+	--load docstrings.lisp \
+	--eval '(sb-texinfo:generate-includes "include/" (list :alexandria) :base-package :alexandria)' \
+	--eval '(quit)'
+
+pdf: include
+	texi2pdf alexandria.texinfo
+
+html: include
+	makeinfo --html --no-split alexandria.texinfo
+
+info: include
+	makeinfo alexandria.texinfo

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/alexandria.texinfo

@@ -0,0 +1,277 @@
+\input texinfo   @c -*-texinfo-*-
+@c %**start of header
+@setfilename alexandria.info
+@settitle Alexandria Manual
+@c %**end of header
+
+@settitle Alexandria Manual -- draft version
+
+@c for install-info
+@dircategory Software development
+@direntry
+* alexandria:           Common Lisp utilities.
+@end direntry
+
+@copying
+Alexandria software and associated documentation are in the public
+domain:
+
+@quotation
+  Authors dedicate this work to public domain, for the benefit of the
+  public at large and to the detriment of the authors' heirs and
+  successors. Authors intends this dedication to be an overt act of
+  relinquishment in perpetuity of all present and future rights under
+  copyright law, whether vested or contingent, in the work. Authors
+  understands that such relinquishment of all rights includes the
+  relinquishment of all rights to enforce (by lawsuit or otherwise)
+  those copyrights in the work.
+
+  Authors recognize that, once placed in the public domain, the work
+  may be freely reproduced, distributed, transmitted, used, modified,
+  built upon, or otherwise exploited by anyone for any purpose,
+  commercial or non-commercial, and in any way, including by methods
+  that have not yet been invented or conceived.
+@end quotation
+
+In those legislations where public domain dedications are not
+recognized or possible, Alexandria is distributed under the following
+terms and conditions:
+
+@quotation
+  Permission is hereby granted, free of charge, to any person
+  obtaining a copy of this software and associated documentation files
+  (the "Software"), to deal in the Software without restriction,
+  including without limitation the rights to use, copy, modify, merge,
+  publish, distribute, sublicense, and/or sell copies of the Software,
+  and to permit persons to whom the Software is furnished to do so,
+  subject to the following conditions:
+
+  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+@end quotation
+@end copying
+
+@titlepage
+
+@title Alexandria Manual
+@subtitle draft version
+
+@c The following two commands start the copyright page.
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+
+@end titlepage
+
+@contents
+
+@ifnottex
+
+@include include/ifnottex.texinfo
+
+@node Top
+@comment  node-name,  next,  previous,  up
+@top Alexandria
+
+@insertcopying
+
+@menu
+* Hash Tables::
+* Data and Control Flow::
+* Conses::
+* Sequences::
+* IO::
+* Macro Writing::
+* Symbols::
+* Arrays::
+* Types::
+* Numbers::
+@end menu
+
+@end ifnottex
+
+@node Hash Tables
+@comment  node-name,  next,  previous,  up
+@chapter Hash Tables
+
+@include include/macro-alexandria-ensure-gethash.texinfo
+@include include/fun-alexandria-copy-hash-table.texinfo
+@include include/fun-alexandria-maphash-keys.texinfo
+@include include/fun-alexandria-maphash-values.texinfo
+@include include/fun-alexandria-hash-table-keys.texinfo
+@include include/fun-alexandria-hash-table-values.texinfo
+@include include/fun-alexandria-hash-table-alist.texinfo
+@include include/fun-alexandria-hash-table-plist.texinfo
+@include include/fun-alexandria-alist-hash-table.texinfo
+@include include/fun-alexandria-plist-hash-table.texinfo
+
+@node Data and Control Flow
+@comment  node-name,  next,  previous,  up
+@chapter Data and Control Flow
+
+@include include/macro-alexandria-define-constant.texinfo
+@include include/macro-alexandria-destructuring-case.texinfo
+@include include/macro-alexandria-ensure-functionf.texinfo
+@include include/macro-alexandria-multiple-value-prog2.texinfo
+@include include/macro-alexandria-named-lambda.texinfo
+@include include/macro-alexandria-nth-value-or.texinfo
+@include include/macro-alexandria-if-let.texinfo
+@include include/macro-alexandria-when-let.texinfo
+@include include/macro-alexandria-when-let-star.texinfo
+@include include/macro-alexandria-switch.texinfo
+@include include/macro-alexandria-cswitch.texinfo
+@include include/macro-alexandria-eswitch.texinfo
+@include include/macro-alexandria-whichever.texinfo
+@include include/macro-alexandria-xor.texinfo
+
+@include include/fun-alexandria-disjoin.texinfo
+@include include/fun-alexandria-conjoin.texinfo
+@include include/fun-alexandria-compose.texinfo
+@include include/fun-alexandria-ensure-function.texinfo
+@include include/fun-alexandria-multiple-value-compose.texinfo
+@include include/fun-alexandria-curry.texinfo
+@include include/fun-alexandria-rcurry.texinfo
+
+@node Conses
+@comment  node-name,  next,  previous,  up
+@chapter Conses
+
+@include include/type-alexandria-proper-list.texinfo
+@include include/type-alexandria-circular-list.texinfo
+
+@include include/macro-alexandria-appendf.texinfo
+@include include/macro-alexandria-nconcf.texinfo
+@include include/macro-alexandria-remove-from-plistf.texinfo
+@include include/macro-alexandria-delete-from-plistf.texinfo
+@include include/macro-alexandria-reversef.texinfo
+@include include/macro-alexandria-nreversef.texinfo
+@include include/macro-alexandria-unionf.texinfo
+@include include/macro-alexandria-nunionf.texinfo
+
+@include include/macro-alexandria-doplist.texinfo
+
+@include include/fun-alexandria-circular-list-p.texinfo
+@include include/fun-alexandria-circular-tree-p.texinfo
+@include include/fun-alexandria-proper-list-p.texinfo
+
+@include include/fun-alexandria-alist-plist.texinfo
+@include include/fun-alexandria-plist-alist.texinfo
+@include include/fun-alexandria-circular-list.texinfo
+@include include/fun-alexandria-make-circular-list.texinfo
+@include include/fun-alexandria-ensure-car.texinfo
+@include include/fun-alexandria-ensure-cons.texinfo
+@include include/fun-alexandria-ensure-list.texinfo
+@include include/fun-alexandria-flatten.texinfo
+@include include/fun-alexandria-lastcar.texinfo
+@include include/fun-alexandria-setf-lastcar.texinfo
+@include include/fun-alexandria-proper-list-length.texinfo
+@include include/fun-alexandria-mappend.texinfo
+@include include/fun-alexandria-map-product.texinfo
+@include include/fun-alexandria-remove-from-plist.texinfo
+@include include/fun-alexandria-delete-from-plist.texinfo
+@include include/fun-alexandria-set-equal.texinfo
+@include include/fun-alexandria-setp.texinfo
+
+@node Sequences
+@comment  node-name,  next,  previous,  up
+@chapter Sequences
+
+@include include/type-alexandria-proper-sequence.texinfo
+
+@include include/macro-alexandria-deletef.texinfo
+@include include/macro-alexandria-removef.texinfo
+
+@include include/fun-alexandria-rotate.texinfo
+@include include/fun-alexandria-shuffle.texinfo
+@include include/fun-alexandria-random-elt.texinfo
+@include include/fun-alexandria-emptyp.texinfo
+@include include/fun-alexandria-sequence-of-length-p.texinfo
+@include include/fun-alexandria-length-equals.texinfo
+@include include/fun-alexandria-copy-sequence.texinfo
+@include include/fun-alexandria-first-elt.texinfo
+@include include/fun-alexandria-setf-first-elt.texinfo
+@include include/fun-alexandria-last-elt.texinfo
+@include include/fun-alexandria-setf-last-elt.texinfo
+@include include/fun-alexandria-starts-with.texinfo
+@include include/fun-alexandria-starts-with-subseq.texinfo
+@include include/fun-alexandria-ends-with.texinfo
+@include include/fun-alexandria-ends-with-subseq.texinfo
+@include include/fun-alexandria-map-combinations.texinfo
+@include include/fun-alexandria-map-derangements.texinfo
+@include include/fun-alexandria-map-permutations.texinfo
+
+@node IO
+@comment  node-name,   next,  previous,  up
+@chapter IO
+
+@include include/fun-alexandria-read-stream-content-into-string.texinfo
+@include include/fun-alexandria-read-file-into-string.texinfo
+@include include/fun-alexandria-read-stream-content-into-byte-vector.texinfo
+@include include/fun-alexandria-read-file-into-byte-vector.texinfo
+
+@node Macro Writing
+@comment  node-name,  next,  previous,  up
+@chapter Macro Writing
+
+@include include/macro-alexandria-once-only.texinfo
+@include include/macro-alexandria-with-gensyms.texinfo
+@include include/macro-alexandria-with-unique-names.texinfo
+@include include/fun-alexandria-featurep.texinfo
+@include include/fun-alexandria-parse-body.texinfo
+@include include/fun-alexandria-parse-ordinary-lambda-list.texinfo
+
+@node Symbols
+@comment  node-name,  next,  previous,  up
+@chapter Symbols
+
+@include include/fun-alexandria-ensure-symbol.texinfo
+@include include/fun-alexandria-format-symbol.texinfo
+@include include/fun-alexandria-make-keyword.texinfo
+@include include/fun-alexandria-make-gensym.texinfo
+@include include/fun-alexandria-make-gensym-list.texinfo
+@include include/fun-alexandria-symbolicate.texinfo
+
+@node Arrays
+@comment  node-name,  next,  previous,  up
+@chapter Arrays
+
+@include include/type-alexandria-array-index.texinfo
+@include include/type-alexandria-array-length.texinfo
+@include include/fun-alexandria-copy-array.texinfo
+
+@node Types
+@comment  node-name,  next,  previous,  up
+@chapter Types
+
+@include include/type-alexandria-string-designator.texinfo
+@include include/macro-alexandria-coercef.texinfo
+@include include/fun-alexandria-of-type.texinfo
+@include include/fun-alexandria-type-equals.texinfo
+
+@node Numbers
+@comment  node-name,  next,  previous,  up
+@chapter Numbers
+
+@include include/macro-alexandria-maxf.texinfo
+@include include/macro-alexandria-minf.texinfo
+
+@include include/fun-alexandria-binomial-coefficient.texinfo
+@include include/fun-alexandria-count-permutations.texinfo
+@include include/fun-alexandria-clamp.texinfo
+@include include/fun-alexandria-lerp.texinfo
+@include include/fun-alexandria-factorial.texinfo
+@include include/fun-alexandria-subfactorial.texinfo
+@include include/fun-alexandria-gaussian-random.texinfo
+@include include/fun-alexandria-iota.texinfo
+@include include/fun-alexandria-map-iota.texinfo
+@include include/fun-alexandria-mean.texinfo
+@include include/fun-alexandria-median.texinfo
+@include include/fun-alexandria-variance.texinfo
+@include include/fun-alexandria-standard-deviation.texinfo
+
+@bye

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/docstrings.lisp

@@ -0,0 +1,881 @@
+;;; -*- lisp -*-
+
+;;;; A docstring extractor for the sbcl manual.  Creates
+;;;; @include-ready documentation from the docstrings of exported
+;;;; symbols of specified packages.
+
+;;;; This software is part of the SBCL software system. SBCL is in the
+;;;; public domain and is provided with absolutely no warranty. See
+;;;; the COPYING file for more information.
+;;;;
+;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled
+;;;; by Nikodemus Siivola.
+
+;;;; TODO
+;;;; * Verbatim text
+;;;; * Quotations
+;;;; * Method documentation untested
+;;;; * Method sorting, somehow
+;;;; * Index for macros & constants?
+;;;; * This is getting complicated enough that tests would be good
+;;;; * Nesting (currently only nested itemizations work)
+;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also
+;;;;   easily generated)
+
+;;;; FIXME: The description below is no longer complete. This
+;;;; should possibly be turned into a contrib with proper documentation.
+
+;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely):
+;;;;
+;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in
+;;;; the argument list of the defun / defmacro.
+;;;;
+;;;; Lines starting with * or - that are followed by intented lines
+;;;; are marked up with @itemize.
+;;;;
+;;;; Lines containing only a SYMBOL that are followed by indented
+;;;; lines are marked up as @table @code, with the SYMBOL as the item.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require 'sb-introspect))
+
+(defpackage :sb-texinfo
+  (:use :cl :sb-mop)
+  (:shadow #:documentation)
+  (:export #:generate-includes #:document-package)
+  (:documentation
+   "Tools to generate TexInfo documentation from docstrings."))
+
+(in-package :sb-texinfo)
+
+;;;; various specials and parameters
+
+(defvar *texinfo-output*)
+(defvar *texinfo-variables*)
+(defvar *documentation-package*)
+(defvar *base-package*)
+
+(defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c))
+
+(defparameter *documentation-types*
+  '(compiler-macro
+    function
+    method-combination
+    setf
+    ;;structure  ; also handled by `type'
+    type
+    variable)
+  "A list of symbols accepted as second argument of `documentation'")
+
+(defparameter *character-replacements*
+  '((#\* . "star") (#\/ . "slash") (#\+ . "plus")
+    (#\< . "lt") (#\> . "gt")
+    (#\= . "equals"))
+  "Characters and their replacement names that `alphanumize' uses. If
+the replacements contain any of the chars they're supposed to replace,
+you deserve to lose.")
+
+(defparameter *characters-to-drop* '(#\\ #\` #\')
+  "Characters that should be removed by `alphanumize'.")
+
+(defparameter *texinfo-escaped-chars* "@{}"
+  "Characters that must be escaped with #\@ for Texinfo.")
+
+(defparameter *itemize-start-characters* '(#\* #\-)
+  "Characters that might start an itemization in docstrings when
+  at the start of a line.")
+
+(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'"
+  "List of characters that make up symbols in a docstring.")
+
+(defparameter *symbol-delimiters* " ,.!?;")
+
+(defparameter *ordered-documentation-kinds*
+  '(package type structure condition class macro))
+
+;;;; utilities
+
+(defun flatten (list)
+  (cond ((null list)
+         nil)
+        ((consp (car list))
+         (nconc (flatten (car list)) (flatten (cdr list))))
+        ((null (cdr list))
+         (cons (car list) nil))
+        (t
+         (cons (car list) (flatten (cdr list))))))
+
+(defun whitespacep (char)
+  (find char #(#\tab #\space #\page)))
+
+(defun setf-name-p (name)
+  (or (symbolp name)
+      (and (listp name) (= 2 (length name)) (eq (car name) 'setf))))
+
+(defgeneric specializer-name (specializer))
+
+(defmethod specializer-name ((specializer eql-specializer))
+  (list 'eql (eql-specializer-object specializer)))
+
+(defmethod specializer-name ((specializer class))
+  (class-name specializer))
+
+(defun ensure-class-precedence-list (class)
+  (unless (class-finalized-p class)
+    (finalize-inheritance class))
+  (class-precedence-list class))
+
+(defun specialized-lambda-list (method)
+  ;; courtecy of AMOP p. 61
+  (let* ((specializers (method-specializers method))
+         (lambda-list (method-lambda-list method))
+         (n-required (length specializers)))
+    (append (mapcar (lambda (arg specializer)
+                      (if  (eq specializer (find-class 't))
+                           arg
+                           `(,arg ,(specializer-name specializer))))
+                    (subseq lambda-list 0 n-required)
+                    specializers)
+           (subseq lambda-list n-required))))
+
+(defun string-lines (string)
+  "Lines in STRING as a vector."
+  (coerce (with-input-from-string (s string)
+            (loop for line = (read-line s nil nil)
+               while line collect line))
+          'vector))
+
+(defun indentation (line)
+  "Position of first non-SPACE character in LINE."
+  (position-if-not (lambda (c) (char= c #\Space)) line))
+
+(defun docstring (x doc-type)
+  (cl:documentation x doc-type))
+
+(defun flatten-to-string (list)
+  (format nil "~{~A~^-~}" (flatten list)))
+
+(defun alphanumize (original)
+  "Construct a string without characters like *`' that will f-star-ck
+up filename handling. See `*character-replacements*' and
+`*characters-to-drop*' for customization."
+  (let ((name (remove-if (lambda (x) (member x *characters-to-drop*))
+                         (if (listp original)
+                             (flatten-to-string original)
+                             (string original))))
+        (chars-to-replace (mapcar #'car *character-replacements*)))
+    (flet ((replacement-delimiter (index)
+             (cond ((or (< index 0) (>= index (length name))) "")
+                   ((alphanumericp (char name index)) "-")
+                   (t ""))))
+      (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
+                                     name)
+         while index
+         do (setf name (concatenate 'string (subseq name 0 index)
+                                    (replacement-delimiter (1- index))
+                                    (cdr (assoc (aref name index)
+                                                *character-replacements*))
+                                    (replacement-delimiter (1+ index))
+                                    (subseq name (1+ index))))))
+    name))
+
+;;;; generating various names
+
+(defgeneric name (thing)
+  (:documentation "Name for a documented thing. Names are either
+symbols or lists of symbols."))
+
+(defmethod name ((symbol symbol))
+  symbol)
+
+(defmethod name ((cons cons))
+  cons)
+
+(defmethod name ((package package))
+  (short-package-name package))
+
+(defmethod name ((method method))
+  (list
+   (generic-function-name (method-generic-function method))
+   (method-qualifiers method)
+   (specialized-lambda-list method)))
+
+;;; Node names for DOCUMENTATION instances
+
+(defgeneric name-using-kind/name (kind name doc))
+
+(defmethod name-using-kind/name (kind (name string) doc)
+  (declare (ignore kind doc))
+  name)
+
+(defmethod name-using-kind/name (kind (name symbol) doc)
+  (declare (ignore kind))
+  (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
+
+(defmethod name-using-kind/name (kind (name list) doc)
+  (declare (ignore kind))
+  (assert (setf-name-p name))
+  (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
+
+(defmethod name-using-kind/name ((kind (eql 'method)) name doc)
+  (format nil "~A~{ ~A~} ~A"
+          (name-using-kind/name nil (first name) doc)
+          (second name)
+          (third name)))
+
+(defun node-name (doc)
+  "Returns TexInfo node name as a string for a DOCUMENTATION instance."
+  (let ((kind (get-kind doc)))
+    (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc))))
+
+(defun short-package-name (package)
+  (unless (eq package *base-package*)
+    (car (sort (copy-list (cons (package-name package) (package-nicknames package)))
+               #'< :key #'length))))
+
+;;; Definition titles for DOCUMENTATION instances
+
+(defgeneric title-using-kind/name (kind name doc))
+
+(defmethod title-using-kind/name (kind (name string) doc)
+  (declare (ignore kind doc))
+  name)
+
+(defmethod title-using-kind/name (kind (name symbol) doc)
+  (declare (ignore kind))
+  (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
+
+(defmethod title-using-kind/name (kind (name list) doc)
+  (declare (ignore kind))
+  (assert (setf-name-p name))
+  (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
+
+(defmethod title-using-kind/name ((kind (eql 'method)) name doc)
+  (format nil "~{~A ~}~A"
+          (second name)
+          (title-using-kind/name nil (first name) doc)))
+
+(defun title-name (doc)
+  "Returns a string to be used as name of the definition."
+  (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc)))
+
+(defun include-pathname (doc)
+  (let* ((kind (get-kind doc))
+         (name (nstring-downcase
+                (if (eq 'package kind)
+                    (format nil "package-~A" (alphanumize (get-name doc)))
+                    (format nil "~A-~A-~A"
+                            (case (get-kind doc)
+                              ((function generic-function) "fun")
+                              (structure "struct")
+                              (variable "var")
+                              (otherwise (symbol-name (get-kind doc))))
+                            (alphanumize (let ((*base-package* nil))
+                                           (short-package-name (get-package doc))))
+                            (alphanumize (get-name doc)))))))
+    (make-pathname :name name  :type "texinfo")))
+
+;;;; documentation class and related methods
+
+(defclass documentation ()
+  ((name :initarg :name :reader get-name)
+   (kind :initarg :kind :reader get-kind)
+   (string :initarg :string :reader get-string)
+   (children :initarg :children :initform nil :reader get-children)
+   (package :initform *documentation-package* :reader get-package)))
+
+(defmethod print-object ((documentation documentation) stream)
+  (print-unreadable-object (documentation stream :type t)
+    (princ (list (get-kind documentation) (get-name documentation)) stream)))
+
+(defgeneric make-documentation (x doc-type string))
+
+(defmethod make-documentation ((x package) doc-type string)
+  (declare (ignore doc-type))
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind 'package
+                 :string string))
+
+(defmethod make-documentation (x (doc-type (eql 'function)) string)
+  (declare (ignore doc-type))
+  (let* ((fdef (and (fboundp x) (fdefinition x)))
+         (name x)
+         (kind (cond ((and (symbolp x) (special-operator-p x))
+                      'special-operator)
+                     ((and (symbolp x) (macro-function x))
+                      'macro)
+                     ((typep fdef 'generic-function)
+                      (assert (or (symbolp name) (setf-name-p name)))
+                      'generic-function)
+                     (fdef
+                      (assert (or (symbolp name) (setf-name-p name)))
+                      'function)))
+         (children (when (eq kind 'generic-function)
+                     (collect-gf-documentation fdef))))
+    (make-instance 'documentation
+                   :name (name x)
+                   :string string
+                   :kind kind
+                   :children children)))
+
+(defmethod make-documentation ((x method) doc-type string)
+  (declare (ignore doc-type))
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind 'method
+                 :string string))
+
+(defmethod make-documentation (x (doc-type (eql 'type)) string)
+  (make-instance 'documentation
+                 :name (name x)
+                 :string string
+                 :kind (etypecase (find-class x nil)
+                         (structure-class 'structure)
+                         (standard-class 'class)
+                         (sb-pcl::condition-class 'condition)
+                         ((or built-in-class null) 'type))))
+
+(defmethod make-documentation (x (doc-type (eql 'variable)) string)
+  (make-instance 'documentation
+                 :name (name x)
+                 :string string
+                 :kind (if (constantp x)
+                           'constant
+                           'variable)))
+
+(defmethod make-documentation (x (doc-type (eql 'setf)) string)
+  (declare (ignore doc-type))
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind 'setf-expander
+                 :string string))
+
+(defmethod make-documentation (x doc-type string)
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind doc-type
+                 :string string))
+
+(defun maybe-documentation (x doc-type)
+  "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
+there is no corresponding docstring."
+  (let ((docstring (docstring x doc-type)))
+    (when docstring
+      (make-documentation x doc-type docstring))))
+
+(defun lambda-list (doc)
+  (case (get-kind doc)
+    ((package constant variable type structure class condition nil)
+     nil)
+    (method
+     (third (get-name doc)))
+    (t
+     ;; KLUDGE: Eugh.
+     ;;
+     ;; believe it or not, the above comment was written before CSR
+     ;; came along and obfuscated this.  (2005-07-04)
+     (when (symbolp (get-name doc))
+       (labels ((clean (x &key optional key)
+                  (typecase x
+                    (atom x)
+                    ((cons (member &optional))
+                     (cons (car x) (clean (cdr x) :optional t)))
+                    ((cons (member &key))
+                     (cons (car x) (clean (cdr x) :key t)))
+                    ((cons (member &whole &environment))
+                     ;; Skip these
+                     (clean (cdr x) :optional optional :key key))
+                    ((cons cons)
+                     (cons
+                      (cond (key (if (consp (caar x))
+                                     (caaar x)
+                                     (caar x)))
+                            (optional (caar x))
+                            (t (clean (car x))))
+                      (clean (cdr x) :key key :optional optional)))
+                    (cons
+                     (cons
+                      (cond ((or key optional) (car x))
+                            (t (clean (car x))))
+                      (clean (cdr x) :key key :optional optional))))))
+         (clean (sb-introspect:function-lambda-list (get-name doc))))))))
+
+(defun get-string-name (x)
+  (let ((name (get-name x)))
+    (cond ((symbolp name)
+           (symbol-name name))
+          ((and (consp name) (eq 'setf (car name)))
+           (symbol-name (second name)))
+          ((stringp name)
+           name)
+          (t
+           (error "Don't know which symbol to use for name ~S" name)))))
+
+(defun documentation< (x y)
+  (let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
+        (p2 (position (get-kind y) *ordered-documentation-kinds*)))
+    (if (or (not (and p1 p2)) (= p1 p2))
+        (string< (get-string-name x) (get-string-name y))
+        (< p1 p2))))
+
+;;;; turning text into texinfo
+
+(defun escape-for-texinfo (string &optional downcasep)
+  "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped
+with #\@. Optionally downcase the result."
+  (let ((result (with-output-to-string (s)
+                  (loop for char across string
+                        when (find char *texinfo-escaped-chars*)
+                        do (write-char #\@ s)
+                        do (write-char char s)))))
+    (if downcasep (nstring-downcase result) result)))
+
+(defun empty-p (line-number lines)
+  (and (< -1 line-number (length lines))
+       (not (indentation (svref lines line-number)))))
+
+;;; line markups
+
+(defvar *not-symbols* '("ANSI" "CLHS"))
+
+(defun locate-symbols (line)
+  "Return a list of index pairs of symbol-like parts of LINE."
+  ;; This would be a good application for a regex ...
+  (let (result)
+    (flet ((grab (start end)
+             (unless (member (subseq line start end) '("ANSI" "CLHS"))
+               (push (list start end) result))))
+      (do ((begin nil)
+           (maybe-begin t)
+           (i 0 (1+ i)))
+          ((= i (length line))
+           ;; symbol at end of line
+           (when (and begin (or (> i (1+ begin))
+                                (not (member (char line begin) '(#\A #\I)))))
+             (grab begin i))
+           (nreverse result))
+        (cond
+          ((and begin (find (char line i) *symbol-delimiters*))
+           ;; symbol end; remember it if it's not "A" or "I"
+           (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
+             (grab begin i))
+           (setf begin nil
+                 maybe-begin t))
+          ((and begin (not (find (char line i) *symbol-characters*)))
+           ;; Not a symbol: abort
+           (setf begin nil))
+          ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
+           ;; potential symbol begin at this position
+           (setf begin i
+                 maybe-begin nil))
+          ((find (char line i) *symbol-delimiters*)
+           ;; potential symbol begin after this position
+           (setf maybe-begin t))
+          (t
+           ;; Not reading a symbol, not at potential start of symbol
+           (setf maybe-begin nil)))))))
+
+(defun texinfo-line (line)
+  "Format symbols in LINE texinfo-style: either as code or as
+variables if the symbol in question is contained in symbols
+*TEXINFO-VARIABLES*."
+  (with-output-to-string (result)
+    (let ((last 0))
+      (dolist (symbol/index (locate-symbols line))
+        (write-string (subseq line last (first symbol/index)) result)
+        (let ((symbol-name (apply #'subseq line symbol/index)))
+          (format result (if (member symbol-name *texinfo-variables*
+                                     :test #'string=)
+                             "@var{~A}"
+                             "@code{~A}")
+                  (string-downcase symbol-name)))
+        (setf last (second symbol/index)))
+      (write-string (subseq line last) result))))
+
+;;; lisp sections
+
+(defun lisp-section-p (line line-number lines)
+  "Returns T if the given LINE looks like start of lisp code --
+ie. if it starts with whitespace followed by a paren or
+semicolon, and the previous line is empty"
+  (let ((offset (indentation line)))
+    (and offset
+         (plusp offset)
+         (find (find-if-not #'whitespacep line) "(;")
+         (empty-p (1- line-number) lines))))
+
+(defun collect-lisp-section (lines line-number)
+  (let ((lisp (loop for index = line-number then (1+ index)
+                    for line = (and (< index (length lines)) (svref lines index))
+                    while (indentation line)
+                    collect line)))
+    (values (length lisp) `("@lisp" ,@lisp "@end lisp"))))
+
+;;; itemized sections
+
+(defun maybe-itemize-offset (line)
+  "Return NIL or the indentation offset if LINE looks like it starts
+an item in an itemization."
+  (let* ((offset (indentation line))
+         (char (when offset (char line offset))))
+    (and offset
+         (member char *itemize-start-characters* :test #'char=)
+         (char= #\Space (find-if-not (lambda (c) (char= c char))
+                                     line :start offset))
+         offset)))
+
+(defun collect-maybe-itemized-section (lines starting-line)
+  ;; Return index of next line to be processed outside
+  (let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
+        (result nil)
+        (lines-consumed 0))
+    (loop for line-number from starting-line below (length lines)
+       for line = (svref lines line-number)
+       for indentation = (indentation line)
+       for offset = (maybe-itemize-offset line)
+       do (cond
+            ((not indentation)
+             ;; empty line -- inserts paragraph.
+             (push "" result)
+             (incf lines-consumed))
+            ((and offset (> indentation this-offset))
+             ;; nested itemization -- handle recursively
+             ;; FIXME: tables in itemizations go wrong
+             (multiple-value-bind (sub-lines-consumed sub-itemization)
+                 (collect-maybe-itemized-section lines line-number)
+               (when sub-lines-consumed
+                 (incf line-number (1- sub-lines-consumed)) ; +1 on next loop
+                 (incf lines-consumed sub-lines-consumed)
+                 (setf result (nconc (nreverse sub-itemization) result)))))
+            ((and offset (= indentation this-offset))
+             ;; start of new item
+             (push (format nil "@item ~A"
+                           (texinfo-line (subseq line (1+ offset))))
+                   result)
+             (incf lines-consumed))
+            ((and (not offset) (> indentation this-offset))
+             ;; continued item from previous line
+             (push (texinfo-line line) result)
+             (incf lines-consumed))
+            (t
+             ;; end of itemization
+             (loop-finish))))
+    ;; a single-line itemization isn't.
+    (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
+        (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize"))
+        nil)))
+
+;;; table sections
+
+(defun tabulation-body-p (offset line-number lines)
+  (when (< line-number (length lines))
+    (let ((offset2 (indentation (svref lines line-number))))
+      (and offset2 (< offset offset2)))))
+
+(defun tabulation-p (offset line-number lines direction)
+  (let ((step  (ecase direction
+                 (:backwards (1- line-number))
+                 (:forwards (1+ line-number)))))
+    (when (and (plusp line-number) (< line-number (length lines)))
+      (and (eql offset (indentation (svref lines line-number)))
+           (or (when (eq direction :backwards)
+                 (empty-p step lines))
+               (tabulation-p offset step lines direction)
+               (tabulation-body-p offset step lines))))))
+
+(defun maybe-table-offset (line-number lines)
+  "Return NIL or the indentation offset if LINE looks like it starts
+an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an
+empty line, another tabulation label, or a tabulation body, (3) and
+followed another tabulation label or a tabulation body."
+  (let* ((line (svref lines line-number))
+         (offset (indentation line))
+         (prev (1- line-number))
+         (next (1+ line-number)))
+    (when (and offset (plusp offset))
+      (and (or (empty-p prev lines)
+               (tabulation-body-p offset prev lines)
+               (tabulation-p offset prev lines :backwards))
+           (or (tabulation-body-p offset next lines)
+               (tabulation-p offset next lines :forwards))
+           offset))))
+
+;;; FIXME: This and itemization are very similar: could they share
+;;; some code, mayhap?
+
+(defun collect-maybe-table-section (lines starting-line)
+  ;; Return index of next line to be processed outside
+  (let ((this-offset (maybe-table-offset starting-line lines))
+        (result nil)
+        (lines-consumed 0))
+    (loop for line-number from starting-line below (length lines)
+          for line = (svref lines line-number)
+          for indentation = (indentation line)
+          for offset = (maybe-table-offset line-number lines)
+          do (cond
+               ((not indentation)
+                ;; empty line -- inserts paragraph.
+                (push "" result)
+                (incf lines-consumed))
+               ((and offset (= indentation this-offset))
+                ;; start of new item, or continuation of previous item
+                (if (and result (search "@item" (car result) :test #'char=))
+                    (push (format nil "@itemx ~A" (texinfo-line line))
+                          result)
+                    (progn
+                      (push "" result)
+                      (push (format nil "@item ~A" (texinfo-line line))
+                            result)))
+                (incf lines-consumed))
+               ((> indentation this-offset)
+                ;; continued item from previous line
+                (push (texinfo-line line) result)
+                (incf lines-consumed))
+               (t
+                ;; end of itemization
+                (loop-finish))))
+     ;; a single-line table isn't.
+    (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
+        (values lines-consumed
+                `("" "@table @emph" ,@(reverse result) "@end table" ""))
+        nil)))
+
+;;; section markup
+
+(defmacro with-maybe-section (index &rest forms)
+  `(multiple-value-bind (count collected) (progn ,@forms)
+    (when count
+      (dolist (line collected)
+        (write-line line *texinfo-output*))
+      (incf ,index (1- count)))))
+
+(defun write-texinfo-string (string &optional lambda-list)
+  "Try to guess as much formatting for a raw docstring as possible."
+  (let ((*texinfo-variables* (flatten lambda-list))
+        (lines (string-lines (escape-for-texinfo string nil))))
+      (loop for line-number from 0 below (length lines)
+            for line = (svref lines line-number)
+            do (cond
+                 ((with-maybe-section line-number
+                    (and (lisp-section-p line line-number lines)
+                         (collect-lisp-section lines line-number))))
+                 ((with-maybe-section line-number
+                    (and (maybe-itemize-offset line)
+                         (collect-maybe-itemized-section lines line-number))))
+                 ((with-maybe-section line-number
+                    (and (maybe-table-offset line-number lines)
+                         (collect-maybe-table-section lines line-number))))
+                 (t
+                  (write-line (texinfo-line line) *texinfo-output*))))))
+
+;;;; texinfo formatting tools
+
+(defun hide-superclass-p (class-name super-name)
+  (let ((super-package (symbol-package super-name)))
+    (or
+     ;; KLUDGE: We assume that we don't want to advertise internal
+     ;; classes in CP-lists, unless the symbol we're documenting is
+     ;; internal as well.
+     (and (member super-package #.'(mapcar #'find-package *undocumented-packages*))
+          (not (eq super-package (symbol-package class-name))))
+     ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
+     ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
+     ;; simply as a matter of convenience. The assumption here is that
+     ;; the inheritance is incidental unless the name of the condition
+     ;; begins with SIMPLE-.
+     (and (member super-name '(simple-error simple-condition))
+          (let ((prefix "SIMPLE-"))
+            (mismatch prefix (string class-name) :end2 (length prefix)))
+          t ; don't return number from MISMATCH
+          ))))
+
+(defun hide-slot-p (symbol slot)
+  ;; FIXME: There is no pricipal reason to avoid the slot docs fo
+  ;; structures and conditions, but their DOCUMENTATION T doesn't
+  ;; currently work with them the way we'd like.
+  (not (and (typep (find-class symbol nil) 'standard-class)
+            (docstring slot t))))
+
+(defun texinfo-anchor (doc)
+  (format *texinfo-output* "@anchor{~A}~%" (node-name doc)))
+
+;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please"
+(defun texinfo-begin (doc &aux *print-pretty*)
+  (let ((kind (get-kind doc)))
+    (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%"
+            (case kind
+              ((package constant variable)
+               "defvr")
+              ((structure class condition type)
+               "deftp")
+              (t
+               "deffn"))
+            (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind))
+            (title-name doc)
+            ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo
+            ;; interactions,so we escape the ampersand -- amusingly for TeX.
+            ;; sbcl.texinfo defines macros that expand @&key and friends to &key.
+            (mapcar (lambda (name)
+                      (if (member name lambda-list-keywords)
+                          (format nil "@~A" name)
+                          name))
+                    (lambda-list doc)))))
+
+(defun texinfo-index (doc)
+  (let ((title (title-name doc)))
+    (case (get-kind doc)
+      ((structure type class condition)
+       (format *texinfo-output* "@tindex ~A~%" title))
+      ((variable constant)
+       (format *texinfo-output* "@vindex ~A~%" title))
+      ((compiler-macro function method-combination macro generic-function)
+       (format *texinfo-output* "@findex ~A~%" title)))))
+
+(defun texinfo-inferred-body (doc)
+  (when (member (get-kind doc) '(class structure condition))
+    (let ((name (get-name doc)))
+      ;; class precedence list
+      (format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%"
+              (remove-if (lambda (class)  (hide-superclass-p name class))
+                         (mapcar #'class-name (ensure-class-precedence-list (find-class name)))))
+      ;; slots
+      (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot))
+                              (class-direct-slots (find-class name)))))
+        (when slots
+          (format *texinfo-output* "Slots:~%@itemize~%")
+          (dolist (slot slots)
+            (format *texinfo-output*
+                    "@item ~(@code{~A}~#[~:; --- ~]~
+                      ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%"
+                    (slot-definition-name slot)
+                    (remove
+                     nil
+                     (mapcar
+                      (lambda (name things)
+                        (if things
+                            (list name (length things) things)))
+                      '("initarg" "reader"  "writer")
+                      (list
+                       (slot-definition-initargs slot)
+                       (slot-definition-readers slot)
+                       (slot-definition-writers slot)))))
+            ;; FIXME: Would be neater to handler as children
+            (write-texinfo-string (docstring slot t)))
+          (format *texinfo-output* "@end itemize~%~%"))))))
+
+(defun texinfo-body (doc)
+  (write-texinfo-string (get-string doc)))
+
+(defun texinfo-end (doc)
+  (write-line (case (get-kind doc)
+                ((package variable constant) "@end defvr")
+                ((structure type class condition) "@end deftp")
+                (t "@end deffn"))
+              *texinfo-output*))
+
+(defun write-texinfo (doc)
+  "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
+  (texinfo-anchor doc)
+  (texinfo-begin doc)
+  (texinfo-index doc)
+  (texinfo-inferred-body doc)
+  (texinfo-body doc)
+  (texinfo-end doc)
+  ;; FIXME: Children should be sorted one way or another
+  (mapc #'write-texinfo (get-children doc)))
+
+;;;; main logic
+
+(defun collect-gf-documentation (gf)
+  "Collects method documentation for the generic function GF"
+  (loop for method in (generic-function-methods gf)
+        for doc = (maybe-documentation method t)
+        when doc
+        collect doc))
+
+(defun collect-name-documentation (name)
+  (loop for type in *documentation-types*
+        for doc = (maybe-documentation name type)
+        when doc
+        collect doc))
+
+(defun collect-symbol-documentation (symbol)
+  "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
+the form DOC instances. See `*documentation-types*' for the possible
+values of doc-type."
+  (nconc (collect-name-documentation symbol)
+         (collect-name-documentation (list 'setf symbol))))
+
+(defun collect-documentation (package)
+  "Collects all documentation for all external symbols of the given
+package, as well as for the package itself."
+  (let* ((*documentation-package* (find-package package))
+         (docs nil))
+    (check-type package package)
+    (do-external-symbols (symbol package)
+      (setf docs (nconc (collect-symbol-documentation symbol) docs)))
+    (let ((doc (maybe-documentation *documentation-package* t)))
+      (when doc
+        (push doc docs)))
+    docs))
+
+(defmacro with-texinfo-file (pathname &body forms)
+  `(with-open-file (*texinfo-output* ,pathname
+                                    :direction :output
+                                    :if-does-not-exist :create
+                                    :if-exists :supersede)
+    ,@forms))
+
+(defun write-ifnottex ()
+  ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to
+  ;; define them for info as well.
+  (flet ((macro (name)
+                 (let ((string (string-downcase name)))
+                   (format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string))))
+    (macro '&allow-other-keys)
+    (macro '&optional)
+    (macro '&rest)
+    (macro '&key)
+    (macro '&body)))
+
+(defun generate-includes (directory packages &key (base-package :cl-user))
+  "Create files in `directory' containing Texinfo markup of all
+docstrings of each exported symbol in `packages'. `directory' is
+created if necessary. If you supply a namestring that doesn't end in a
+slash, you lose. The generated files are of the form
+\"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included
+via @include statements. Texinfo syntax-significant characters are
+escaped in symbol names, but if a docstring contains invalid Texinfo
+markup, you lose."
+  (handler-bind ((warning #'muffle-warning))
+    (let ((directory (merge-pathnames (pathname directory)))
+          (*base-package* (find-package base-package)))
+      (ensure-directories-exist directory)
+      (dolist (package packages)
+        (dolist (doc (collect-documentation (find-package package)))
+          (with-texinfo-file (merge-pathnames (include-pathname doc) directory)
+            (write-texinfo doc))))
+      (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory)
+        (write-ifnottex))
+      directory)))
+
+(defun document-package (package &optional filename)
+  "Create a file containing all available documentation for the
+exported symbols of `package' in Texinfo format. If `filename' is not
+supplied, a file \"<packagename>.texinfo\" is generated.
+
+The definitions can be referenced using Texinfo statements like
+@ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
+syntax-significant characters are escaped in symbol names, but if a
+docstring contains invalid Texinfo markup, you lose."
+  (handler-bind ((warning #'muffle-warning))
+    (let* ((package (find-package package))
+           (filename (or filename (make-pathname
+                                   :name (string-downcase (short-package-name package))
+                                   :type "texinfo")))
+           (docs (sort (collect-documentation package) #'documentation<)))
+      (with-texinfo-file filename
+        (dolist (doc docs)
+          (write-texinfo doc)))
+      filename)))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/features.lisp

@@ -0,0 +1,14 @@
+(in-package :alexandria)
+
+(defun featurep (feature-expression)
+  "Returns T if the argument matches the state of the *FEATURES*
+list and NIL if it does not. FEATURE-EXPRESSION can be any atom
+or list acceptable to the reader macros #+ and #-."
+  (etypecase feature-expression
+    (symbol (not (null (member feature-expression *features*))))
+    (cons (check-type (first feature-expression) symbol)
+          (eswitch ((first feature-expression) :test 'string=)
+            (:and (every #'featurep (rest feature-expression)))
+            (:or  (some #'featurep (rest feature-expression)))
+            (:not (assert (= 2 (length feature-expression)))
+                  (not (featurep (second feature-expression))))))))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/functions.lisp

@@ -0,0 +1,161 @@
+(in-package :alexandria)
+
+;;; To propagate return type and allow the compiler to eliminate the IF when
+;;; it is known if the argument is function or not.
+(declaim (inline ensure-function))
+
+(declaim (ftype (function (t) (values function &optional))
+                ensure-function))
+(defun ensure-function (function-designator)
+  "Returns the function designated by FUNCTION-DESIGNATOR:
+if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
+it must be a function name and its FDEFINITION is returned."
+  (if (functionp function-designator)
+      function-designator
+      (fdefinition function-designator)))
+
+(define-modify-macro ensure-functionf/1 () ensure-function)
+
+(defmacro ensure-functionf (&rest places)
+  "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of
+PLACES contains a function."
+  `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places)))
+
+(defun disjoin (predicate &rest more-predicates)
+  "Returns a function that applies each of PREDICATE and MORE-PREDICATE
+functions in turn to its arguments, returning the primary value of the first
+predicate that returns true, without calling the remaining predicates.
+If none of the predicates returns true, NIL is returned."
+  (declare (optimize (speed 3) (safety 1) (debug 1)))
+  (let ((predicate (ensure-function predicate))
+	(more-predicates (mapcar #'ensure-function more-predicates)))
+    (lambda (&rest arguments)
+      (or (apply predicate arguments)
+	  (some (lambda (p)
+		  (declare (type function p))
+		  (apply p arguments))
+		more-predicates)))))
+
+(defun conjoin (predicate &rest more-predicates)
+  "Returns a function that applies each of PREDICATE and MORE-PREDICATE
+functions in turn to its arguments, returning NIL if any of the predicates
+returns false, without calling the remaining predicates. If none of the
+predicates returns false, returns the primary value of the last predicate."
+  (if (null more-predicates)
+      predicate
+      (lambda (&rest arguments)
+	(and (apply predicate arguments)
+	     ;; Cannot simply use CL:EVERY because we want to return the
+	     ;; non-NIL value of the last predicate if all succeed.
+	     (do ((tail (cdr more-predicates) (cdr tail))
+		  (head (car more-predicates) (car tail)))
+		 ((not tail)
+		  (apply head arguments))
+	       (unless (apply head arguments)
+		 (return nil)))))))
+
+
+(defun compose (function &rest more-functions)
+  "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
+arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS,
+and then calling the next one with the primary value of the last."
+  (declare (optimize (speed 3) (safety 1) (debug 1)))
+  (reduce (lambda (f g)
+	    (let ((f (ensure-function f))
+		  (g (ensure-function g)))
+	      (lambda (&rest arguments)
+		(declare (dynamic-extent arguments))
+		(funcall f (apply g arguments)))))
+          more-functions
+          :initial-value function))
+
+(define-compiler-macro compose (function &rest more-functions)
+  (labels ((compose-1 (funs)
+             (if (cdr funs)
+                 `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+                 `(apply ,(car funs) arguments))))
+    (let* ((args (cons function more-functions))
+           (funs (make-gensym-list (length args) "COMPOSE")))
+      `(let ,(loop for f in funs for arg in args
+		   collect `(,f (ensure-function ,arg)))
+         (declare (optimize (speed 3) (safety 1) (debug 1)))
+         (lambda (&rest arguments)
+           (declare (dynamic-extent arguments))
+           ,(compose-1 funs))))))
+
+(defun multiple-value-compose (function &rest more-functions)
+    "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies
+its arguments to each in turn, starting from the rightmost of
+MORE-FUNCTIONS, and then calling the next one with all the return values of
+the last."
+  (declare (optimize (speed 3) (safety 1) (debug 1)))
+  (reduce (lambda (f g)
+	    (let ((f (ensure-function f))
+		  (g (ensure-function g)))
+	      (lambda (&rest arguments)
+		(declare (dynamic-extent arguments))
+		(multiple-value-call f (apply g arguments)))))
+          more-functions
+          :initial-value function))
+
+(define-compiler-macro multiple-value-compose (function &rest more-functions)
+  (labels ((compose-1 (funs)
+             (if (cdr funs)
+                 `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
+                 `(apply ,(car funs) arguments))))
+    (let* ((args (cons function more-functions))
+           (funs (make-gensym-list (length args) "MV-COMPOSE")))
+      `(let ,(mapcar #'list funs args)
+         (declare (optimize (speed 3) (safety 1) (debug 1)))
+         (lambda (&rest arguments)
+           (declare (dynamic-extent arguments))
+           ,(compose-1 funs))))))
+
+(declaim (inline curry rcurry))
+
+(defun curry (function &rest arguments)
+  "Returns a function that applies ARGUMENTS and the arguments
+it is called with to FUNCTION."
+  (declare (optimize (speed 3) (safety 1)))
+  (let ((fn (ensure-function function)))
+    (lambda (&rest more)
+      (declare (dynamic-extent more))
+      ;; Using M-V-C we don't need to append the arguments.
+      (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+(define-compiler-macro curry (function &rest arguments)
+  (let ((curries (make-gensym-list (length arguments) "CURRY"))
+        (fun (gensym "FUN")))
+    `(let ((,fun (ensure-function ,function))
+           ,@(mapcar #'list curries arguments))
+       (declare (optimize (speed 3) (safety 1)))
+       (lambda (&rest more)
+         (declare (dynamic-extent more))
+         (apply ,fun ,@curries more)))))
+
+(defun rcurry (function &rest arguments)
+  "Returns a function that applies the arguments it is called
+with and ARGUMENTS to FUNCTION."
+  (declare (optimize (speed 3) (safety 1)))
+  (let ((fn (ensure-function function)))
+    (lambda (&rest more)
+      (declare (dynamic-extent more))
+      (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+(define-compiler-macro rcurry (function &rest arguments)
+  (let ((rcurries (make-gensym-list (length arguments) "RCURRY"))
+        (fun (gensym "FUN")))
+    `(let ((,fun (ensure-function ,function))
+           ,@(mapcar #'list rcurries arguments))
+       (declare (optimize (speed 3) (safety 1)))
+       (lambda (&rest more)
+         (declare (dynamic-extent more))
+         (multiple-value-call ,fun (values-list more) ,@rcurries)))))
+
+(declaim (notinline curry rcurry))
+
+(defmacro named-lambda (name lambda-list &body body)
+  "Expands into a lambda-expression within whose BODY NAME denotes the
+corresponding function."
+  `(labels ((,name ,lambda-list ,@body))
+     #',name))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/hash-tables.lisp

@@ -0,0 +1,101 @@
+(in-package :alexandria)
+
+(defmacro ensure-gethash (key hash-table &optional default)
+  "Like GETHASH, but if KEY is not found in the HASH-TABLE saves the DEFAULT
+under key before returning it. Secondary return value is true if key was
+already in the table."
+  (once-only (key hash-table)
+    (with-unique-names (value presentp)
+      `(multiple-value-bind (,value ,presentp) (gethash ,key ,hash-table)
+         (if ,presentp
+             (values ,value ,presentp)
+             (values (setf (gethash ,key ,hash-table) ,default) nil))))))
+
+(defun copy-hash-table (table &key key test size
+                                   rehash-size rehash-threshold)
+  "Returns a copy of hash table TABLE, with the same keys and values
+as the TABLE. The copy has the same properties as the original, unless
+overridden by the keyword arguments.
+
+Before each of the original values is set into the new hash-table, KEY
+is invoked on the value. As KEY defaults to CL:IDENTITY, a shallow
+copy is returned by default."
+  (setf key (or key 'identity))
+  (setf test (or test (hash-table-test table)))
+  (setf size (or size (hash-table-size table)))
+  (setf rehash-size (or rehash-size (hash-table-rehash-size table)))
+  (setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table)))
+  (let ((copy (make-hash-table :test test :size size
+                               :rehash-size rehash-size
+                               :rehash-threshold rehash-threshold)))
+    (maphash (lambda (k v)
+               (setf (gethash k copy) (funcall key v)))
+             table)
+    copy))
+
+(declaim (inline maphash-keys))
+(defun maphash-keys (function table)
+  "Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE."
+  (maphash (lambda (k v)
+             (declare (ignore v))
+             (funcall function k))
+           table))
+
+(declaim (inline maphash-values))
+(defun maphash-values (function table)
+  "Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE."
+  (maphash (lambda (k v)
+             (declare (ignore k))
+             (funcall function v))
+           table))
+
+(defun hash-table-keys (table)
+  "Returns a list containing the keys of hash table TABLE."
+  (let ((keys nil))
+    (maphash-keys (lambda (k)
+                    (push k keys))
+                  table)
+    keys))
+
+(defun hash-table-values (table)
+  "Returns a list containing the values of hash table TABLE."
+  (let ((values nil))
+    (maphash-values (lambda (v)
+                      (push v values))
+                    table)
+    values))
+
+(defun hash-table-alist (table)
+  "Returns an association list containing the keys and values of hash table
+TABLE."
+  (let ((alist nil))
+    (maphash (lambda (k v)
+               (push (cons k v) alist))
+             table)
+    alist))
+
+(defun hash-table-plist (table)
+  "Returns a property list containing the keys and values of hash table
+TABLE."
+  (let ((plist nil))
+    (maphash (lambda (k v)
+               (setf plist (list* k v plist)))
+             table)
+    plist))
+
+(defun alist-hash-table (alist &rest hash-table-initargs)
+  "Returns a hash table containing the keys and values of the association list
+ALIST. Hash table is initialized using the HASH-TABLE-INITARGS."
+  (let ((table (apply #'make-hash-table hash-table-initargs)))
+    (dolist (cons alist)
+      (ensure-gethash (car cons) table (cdr cons)))
+    table))
+
+(defun plist-hash-table (plist &rest hash-table-initargs)
+  "Returns a hash table containing the keys and values of the property list
+PLIST. Hash table is initialized using the HASH-TABLE-INITARGS."
+  (let ((table (apply #'make-hash-table hash-table-initargs)))
+    (do ((tail plist (cddr tail)))
+        ((not tail))
+      (ensure-gethash (car tail) table (cadr tail)))
+    table))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/io.lisp

@@ -0,0 +1,172 @@
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+
+(in-package :alexandria)
+
+(defmacro with-open-file* ((stream filespec &key direction element-type
+                                   if-exists if-does-not-exist external-format)
+                           &body body)
+  "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments mean to use
+the default value specified for OPEN."
+  (once-only (direction element-type if-exists if-does-not-exist external-format)
+    `(with-open-stream
+         (,stream (apply #'open ,filespec
+                         (append
+                          (when ,direction
+                            (list :direction ,direction))
+                          (when ,element-type
+                            (list :element-type ,element-type))
+                          (when ,if-exists
+                            (list :if-exists ,if-exists))
+                          (when ,if-does-not-exist
+                            (list :if-does-not-exist ,if-does-not-exist))
+                          (when ,external-format
+                            (list :external-format ,external-format)))))
+       ,@body)))
+
+(defmacro with-input-from-file ((stream-name file-name &rest args
+                                             &key (direction nil direction-p)
+                                             &allow-other-keys)
+                                &body body)
+  "Evaluate BODY with STREAM-NAME to an input stream on the file
+FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
+which is only sent to WITH-OPEN-FILE when it's not NIL."
+  (declare (ignore direction))
+  (when direction-p
+    (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
+  `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
+     ,@body))
+
+(defmacro with-output-to-file ((stream-name file-name &rest args
+                                            &key (direction nil direction-p)
+                                            &allow-other-keys)
+			       &body body)
+  "Evaluate BODY with STREAM-NAME to an output stream on the file
+FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
+which is only sent to WITH-OPEN-FILE when it's not NIL."
+  (declare (ignore direction))
+  (when direction-p
+    (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
+  `(with-open-file* (,stream-name ,file-name :direction :output ,@args)
+     ,@body))
+
+(defun read-stream-content-into-string (stream &key (buffer-size 4096))
+  "Return the \"content\" of STREAM as a fresh string."
+  (check-type buffer-size positive-integer)
+  (let ((*print-pretty* nil))
+    (with-output-to-string (datum)
+      (let ((buffer (make-array buffer-size :element-type 'character)))
+        (loop
+          :for bytes-read = (read-sequence buffer stream)
+          :do (write-sequence buffer datum :start 0 :end bytes-read)
+          :while (= bytes-read buffer-size))))))
+
+(defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
+  "Return the contents of the file denoted by PATHNAME as a fresh string.
+
+The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
+unless it's NIL, which means the system default."
+  (with-input-from-file
+      (file-stream pathname :external-format external-format)
+    (read-stream-content-into-string file-stream :buffer-size buffer-size)))
+
+(defun write-string-into-file (string pathname &key (if-exists :error)
+                                                    if-does-not-exist
+                                                    external-format)
+  "Write STRING to PATHNAME.
+
+The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
+unless it's NIL, which means the system default."
+  (with-output-to-file (file-stream pathname :if-exists if-exists
+                                    :if-does-not-exist if-does-not-exist
+                                    :external-format external-format)
+    (write-sequence string file-stream)))
+
+(defun read-stream-content-into-byte-vector (stream &key ((%length length))
+                                                         (initial-size 4096))
+  "Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector."
+  (check-type length (or null non-negative-integer))
+  (check-type initial-size positive-integer)
+  (do ((buffer (make-array (or length initial-size)
+                           :element-type '(unsigned-byte 8)))
+       (offset 0)
+       (offset-wanted 0))
+      ((or (/= offset-wanted offset)
+           (and length (>= offset length)))
+       (if (= offset (length buffer))
+           buffer
+           (subseq buffer 0 offset)))
+    (unless (zerop offset)
+      (let ((new-buffer (make-array (* 2 (length buffer))
+                                    :element-type '(unsigned-byte 8))))
+        (replace new-buffer buffer)
+        (setf buffer new-buffer)))
+    (setf offset-wanted (length buffer)
+          offset (read-sequence buffer stream :start offset))))
+
+(defun read-file-into-byte-vector (pathname)
+  "Read PATHNAME into a freshly allocated (unsigned-byte 8) vector."
+  (with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
+    (read-stream-content-into-byte-vector stream '%length (file-length stream))))
+
+(defun write-byte-vector-into-file (bytes pathname &key (if-exists :error)
+                                                       if-does-not-exist)
+  "Write BYTES to PATHNAME."
+  (check-type bytes (vector (unsigned-byte 8)))
+  (with-output-to-file (stream pathname :if-exists if-exists
+                               :if-does-not-exist if-does-not-exist
+                               :element-type '(unsigned-byte 8))
+    (write-sequence bytes stream)))
+
+(defun copy-file (from to &key (if-to-exists :supersede)
+			       (element-type '(unsigned-byte 8)) finish-output)
+  (with-input-from-file (input from :element-type element-type)
+    (with-output-to-file (output to :element-type element-type
+				    :if-exists if-to-exists)
+      (copy-stream input output
+                   :element-type element-type
+                   :finish-output finish-output))))
+
+(defun copy-stream (input output &key (element-type (stream-element-type input))
+                    (buffer-size 4096)
+                    (buffer (make-array buffer-size :element-type element-type))
+                    (start 0) end
+                    finish-output)
+  "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must
+be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have
+compatible element-types."
+  (check-type start non-negative-integer)
+  (check-type end (or null non-negative-integer))
+  (check-type buffer-size positive-integer)
+  (when (and end
+             (< end start))
+    (error "END is smaller than START in ~S" 'copy-stream))
+  (let ((output-position 0)
+        (input-position 0))
+    (unless (zerop start)
+      ;; FIXME add platform specific optimization to skip seekable streams
+      (loop while (< input-position start)
+            do (let ((n (read-sequence buffer input
+                                       :end (min (length buffer)
+                                                 (- start input-position)))))
+                 (when (zerop n)
+                   (error "~@<Could not read enough bytes from the input to fulfill ~
+                           the :START ~S requirement in ~S.~:@>" 'copy-stream start))
+                 (incf input-position n))))
+    (assert (= input-position start))
+    (loop while (or (null end) (< input-position end))
+          do (let ((n (read-sequence buffer input
+                                     :end (when end
+                                            (min (length buffer)
+                                                 (- end input-position))))))
+               (when (zerop n)
+                 (if end
+                     (error "~@<Could not read enough bytes from the input to fulfill ~
+                          the :END ~S requirement in ~S.~:@>" 'copy-stream end)
+                     (return)))
+               (incf input-position n)
+               (write-sequence buffer output :end n)
+               (incf output-position n)))
+    (when finish-output
+      (finish-output output))
+    output-position))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/lists.lisp

@@ -0,0 +1,367 @@
+(in-package :alexandria)
+
+(declaim (inline safe-endp))
+(defun safe-endp (x)
+  (declare (optimize safety))
+  (endp x))
+
+(defun alist-plist (alist)
+  "Returns a property list containing the same keys and values as the
+association list ALIST in the same order."
+  (let (plist)
+    (dolist (pair alist)
+      (push (car pair) plist)
+      (push (cdr pair) plist))
+    (nreverse plist)))
+
+(defun plist-alist (plist)
+  "Returns an association list containing the same keys and values as the
+property list PLIST in the same order."
+  (let (alist)
+    (do ((tail plist (cddr tail)))
+        ((safe-endp tail) (nreverse alist))
+      (push (cons (car tail) (cadr tail)) alist))))
+
+(declaim (inline racons))
+(defun racons (key value ralist)
+  (acons value key ralist))
+
+(macrolet
+    ((define-alist-get (name get-entry get-value-from-entry add doc)
+       `(progn
+          (declaim (inline ,name))
+          (defun ,name (alist key &key (test 'eql))
+            ,doc
+            (let ((entry (,get-entry key alist :test test)))
+              (values (,get-value-from-entry entry) entry)))
+          (define-setf-expander ,name (place key &key (test ''eql)
+                                       &environment env)
+            (multiple-value-bind
+                  (temporary-variables initforms newvals setter getter)
+                (get-setf-expansion place env)
+              (when (cdr newvals)
+                (error "~A cannot store multiple values in one place" ',name))
+              (with-unique-names (new-value key-val test-val alist entry)
+                (values
+                 (append temporary-variables
+                         (list alist
+                               key-val
+                               test-val
+                               entry))
+                 (append initforms
+                         (list getter
+                               key
+                               test
+                               `(,',get-entry ,key-val ,alist :test ,test-val)))
+                 `(,new-value)
+                 `(cond
+                    (,entry
+                     (setf (,',get-value-from-entry ,entry) ,new-value))
+                    (t
+                     (let ,newvals
+                       (setf ,(first newvals) (,',add ,key ,new-value ,alist))
+                       ,setter
+                       ,new-value)))
+                 `(,',get-value-from-entry ,entry))))))))
+ (define-alist-get assoc-value assoc cdr acons
+"ASSOC-VALUE is an alist accessor very much like ASSOC, but it can
+be used with SETF.")
+ (define-alist-get rassoc-value rassoc car racons
+"RASSOC-VALUE is an alist accessor very much like RASSOC, but it can
+be used with SETF."))
+
+(defun malformed-plist (plist)
+  (error "Malformed plist: ~S" plist))
+
+(defmacro doplist ((key val plist &optional values) &body body)
+  "Iterates over elements of PLIST. BODY can be preceded by
+declarations, and is like a TAGBODY. RETURN may be used to terminate
+the iteration early. If RETURN is not used, returns VALUES."
+  (multiple-value-bind (forms declarations) (parse-body body)
+    (with-gensyms (tail loop results)
+      `(block nil
+         (flet ((,results ()
+                  (let (,key ,val)
+                    (declare (ignorable ,key ,val))
+                    (return ,values))))
+           (let* ((,tail ,plist)
+                  (,key (if ,tail
+                            (pop ,tail)
+                            (,results)))
+                 (,val (if ,tail
+                           (pop ,tail)
+                           (malformed-plist ',plist))))
+            (declare (ignorable ,key ,val))
+            ,@declarations
+            (tagbody
+               ,loop
+               ,@forms
+               (setf ,key (if ,tail
+                              (pop ,tail)
+                              (,results))
+                     ,val (if ,tail
+                              (pop ,tail)
+                              (malformed-plist ',plist)))
+               (go ,loop))))))))
+
+(define-modify-macro appendf (&rest lists) append
+  "Modify-macro for APPEND. Appends LISTS to the place designated by the first
+argument.")
+
+(define-modify-macro nconcf (&rest lists) nconc
+  "Modify-macro for NCONC. Concatenates LISTS to place designated by the first
+argument.")
+
+(define-modify-macro unionf (list &rest args) union
+  "Modify-macro for UNION. Saves the union of LIST and the contents of the
+place designated by the first argument to the designated place.")
+
+(define-modify-macro nunionf (list &rest args) nunion
+  "Modify-macro for NUNION. Saves the union of LIST and the contents of the
+place designated by the first argument to the designated place. May modify
+either argument.")
+
+(define-modify-macro reversef () reverse
+  "Modify-macro for REVERSE. Copies and reverses the list stored in the given
+place and saves back the result into the place.")
+
+(define-modify-macro nreversef () nreverse
+  "Modify-macro for NREVERSE. Reverses the list stored in the given place by
+destructively modifying it and saves back the result into the place.")
+
+(defun circular-list (&rest elements)
+  "Creates a circular list of ELEMENTS."
+  (let ((cycle (copy-list elements)))
+    (nconc cycle cycle)))
+
+(defun circular-list-p (object)
+  "Returns true if OBJECT is a circular list, NIL otherwise."
+  (and (listp object)
+       (do ((fast object (cddr fast))
+            (slow (cons (car object) (cdr object)) (cdr slow)))
+           (nil)
+         (unless (and (consp fast) (listp (cdr fast)))
+           (return nil))
+         (when (eq fast slow)
+           (return t)))))
+
+(defun circular-tree-p (object)
+  "Returns true if OBJECT is a circular tree, NIL otherwise."
+  (labels ((circularp (object seen)
+             (and (consp object)
+                  (do ((fast (cons (car object) (cdr object)) (cddr fast))
+                       (slow object (cdr slow)))
+                      (nil)
+                    (when (or (eq fast slow) (member slow seen))
+                      (return-from circular-tree-p t))
+                    (when (or (not (consp fast)) (not (consp (cdr slow))))
+                      (return
+                        (do ((tail object (cdr tail)))
+                            ((not (consp tail))
+                             nil)
+                          (let ((elt (car tail)))
+                            (circularp elt (cons object seen))))))))))
+    (circularp object nil)))
+
+(defun proper-list-p (object)
+  "Returns true if OBJECT is a proper list."
+  (cond ((not object)
+         t)
+        ((consp object)
+         (do ((fast object (cddr fast))
+              (slow (cons (car object) (cdr object)) (cdr slow)))
+             (nil)
+           (unless (and (listp fast) (consp (cdr fast)))
+             (return (and (listp fast) (not (cdr fast)))))
+           (when (eq fast slow)
+             (return nil))))
+        (t
+         nil)))
+
+(deftype proper-list ()
+  "Type designator for proper lists. Implemented as a SATISFIES type, hence
+not recommended for performance intensive use. Main usefullness as a type
+designator of the expected type in a TYPE-ERROR."
+  `(and list (satisfies proper-list-p)))
+
+(defun circular-list-error (list)
+  (error 'type-error
+         :datum list
+         :expected-type '(and list (not circular-list))))
+
+(macrolet ((def (name lambda-list doc step declare ret1 ret2)
+             (assert (member 'list lambda-list))
+             `(defun ,name ,lambda-list
+                ,doc
+                (do ((last list fast)
+                     (fast list (cddr fast))
+                     (slow (cons (car list) (cdr list)) (cdr slow))
+                     ,@(when step (list step)))
+                    (nil)
+                  (declare (dynamic-extent slow) ,@(when declare (list declare))
+                           (ignorable last))
+                  (when (safe-endp fast)
+                    (return ,ret1))
+                  (when (safe-endp (cdr fast))
+                    (return ,ret2))
+                  (when (eq fast slow)
+                    (circular-list-error list))))))
+  (def proper-list-length (list)
+    "Returns length of LIST, signalling an error if it is not a proper list."
+    (n 1 (+ n 2))
+    ;; KLUDGE: Most implementations don't actually support lists with bignum
+    ;; elements -- and this is WAY faster on most implementations then declaring
+    ;; N to be an UNSIGNED-BYTE.
+    (fixnum n)
+    (1- n)
+    n)
+
+  (def lastcar (list)
+      "Returns the last element of LIST. Signals a type-error if LIST is not a
+proper list."
+    nil
+    nil
+    (cadr last)
+    (car fast))
+
+  (def (setf lastcar) (object list)
+      "Sets the last element of LIST. Signals a type-error if LIST is not a proper
+list."
+    nil
+    nil
+    (setf (cadr last) object)
+    (setf (car fast) object)))
+
+(defun make-circular-list (length &key initial-element)
+  "Creates a circular list of LENGTH with the given INITIAL-ELEMENT."
+  (let ((cycle (make-list length :initial-element initial-element)))
+    (nconc cycle cycle)))
+
+(deftype circular-list ()
+  "Type designator for circular lists. Implemented as a SATISFIES type, so not
+recommended for performance intensive use. Main usefullness as the
+expected-type designator of a TYPE-ERROR."
+  `(satisfies circular-list-p))
+
+(defun ensure-car (thing)
+  "If THING is a CONS, its CAR is returned. Otherwise THING is returned."
+  (if (consp thing)
+      (car thing)
+      thing))
+
+(defun ensure-cons (cons)
+  "If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS
+  in the car, and NIL in the cdr."
+  (if (consp cons)
+      cons
+      (cons cons nil)))
+
+(defun ensure-list (list)
+  "If LIST is a list, it is returned. Otherwise returns the list designated by LIST."
+  (if (listp list)
+      list
+      (list list)))
+
+(defun remove-from-plist (plist &rest keys)
+  "Returns a propery-list with same keys and values as PLIST, except that keys
+in the list designated by KEYS and values corresponding to them are removed.
+The returned property-list may share structure with the PLIST, but PLIST is
+not destructively modified. Keys are compared using EQ."
+  (declare (optimize (speed 3)))
+  ;; FIXME: possible optimization: (remove-from-plist '(:x 0 :a 1 :b 2) :a)
+  ;; could return the tail without consing up a new list.
+  (loop for (key . rest) on plist by #'cddr
+        do (assert rest () "Expected a proper plist, got ~S" plist)
+        unless (member key keys :test #'eq)
+        collect key and collect (first rest)))
+
+(defun delete-from-plist (plist &rest keys)
+  "Just like REMOVE-FROM-PLIST, but this version may destructively modify the
+provided PLIST."
+  (declare (optimize speed))
+  (loop with head = plist
+        with tail = nil   ; a nil tail means an empty result so far
+        for (key . rest) on plist by #'cddr
+        do (assert rest () "Expected a proper plist, got ~S" plist)
+           (if (member key keys :test #'eq)
+               ;; skip over this pair
+               (let ((next (cdr rest)))
+                 (if tail
+                     (setf (cdr tail) next)
+                     (setf head next)))
+               ;; keep this pair
+               (setf tail rest))
+        finally (return head)))
+
+(define-modify-macro remove-from-plistf (&rest keys) remove-from-plist
+                     "Modify macro for REMOVE-FROM-PLIST.")
+(define-modify-macro delete-from-plistf (&rest keys) delete-from-plist
+                     "Modify macro for DELETE-FROM-PLIST.")
+
+(declaim (inline sans))
+(defun sans (plist &rest keys)
+  "Alias of REMOVE-FROM-PLIST for backward compatibility."
+  (apply #'remove-from-plist plist keys))
+
+(defun mappend (function &rest lists)
+  "Applies FUNCTION to respective element(s) of each LIST, appending all the
+all the result list to a single list. FUNCTION must return a list."
+  (loop for results in (apply #'mapcar function lists)
+        append results))
+
+(defun setp (object &key (test #'eql) (key #'identity))
+  "Returns true if OBJECT is a list that denotes a set, NIL otherwise. A list
+denotes a set if each element of the list is unique under KEY and TEST."
+  (and (listp object)
+       (let (seen)
+         (dolist (elt object t)
+           (let ((key (funcall key elt)))
+             (if (member key seen :test test)
+                 (return nil)
+                 (push key seen)))))))
+
+(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
+  "Returns true if every element of LIST1 matches some element of LIST2 and
+every element of LIST2 matches some element of LIST1. Otherwise returns false."
+  (let ((keylist1 (if keyp (mapcar key list1) list1))
+        (keylist2 (if keyp (mapcar key list2) list2)))
+    (and (dolist (elt keylist1 t)
+           (or (member elt keylist2 :test test)
+               (return nil)))
+         (dolist (elt keylist2 t)
+           (or (member elt keylist1 :test test)
+               (return nil))))))
+
+(defun map-product (function list &rest more-lists)
+  "Returns a list containing the results of calling FUNCTION with one argument
+from LIST, and one from each of MORE-LISTS for each combination of arguments.
+In other words, returns the product of LIST and MORE-LISTS using FUNCTION.
+
+Example:
+
+ (map-product 'list '(1 2) '(3 4) '(5 6))
+  => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
+      (2 3 5) (2 3 6) (2 4 5) (2 4 6))
+"
+  (labels ((%map-product (f lists)
+             (let ((more (cdr lists))
+                   (one (car lists)))
+               (if (not more)
+                   (mapcar f one)
+                   (mappend (lambda (x)
+                              (%map-product (curry f x) more))
+                            one)))))
+    (%map-product (ensure-function function) (cons list more-lists))))
+
+(defun flatten (tree)
+  "Traverses the tree in order, collecting non-null leaves into a list."
+  (let (list)
+    (labels ((traverse (subtree)
+               (when subtree
+                 (if (consp subtree)
+                     (progn
+                       (traverse (car subtree))
+                       (traverse (cdr subtree)))
+                     (push subtree list)))))
+      (traverse tree))
+    (nreverse list)))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/macros.lisp

@@ -0,0 +1,370 @@
+(in-package :alexandria)
+
+(defmacro with-gensyms (names &body forms)
+  "Binds a set of variables to gensyms and evaluates the implicit progn FORMS.
+
+Each element within NAMES is either a symbol SYMBOL or a pair (SYMBOL
+STRING-DESIGNATOR). Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
+
+Each pair (SYMBOL STRING-DESIGNATOR) specifies that the variable named by SYMBOL
+should be bound to a symbol constructed using GENSYM with the string designated
+by STRING-DESIGNATOR being its first argument."
+  `(let ,(mapcar (lambda (name)
+                   (multiple-value-bind (symbol string)
+                       (etypecase name
+                         (symbol
+                          (values name (symbol-name name)))
+                         ((cons symbol (cons string-designator null))
+                          (values (first name) (string (second name)))))
+                     `(,symbol (gensym ,string))))
+                 names)
+     ,@forms))
+
+(defmacro with-unique-names (names &body forms)
+  "Alias for WITH-GENSYMS."
+  `(with-gensyms ,names ,@forms))
+
+(defmacro once-only (specs &body forms)
+  "Constructs code whose primary goal is to help automate the handling of
+multiple evaluation within macros. Multiple evaluation is handled by introducing
+intermediate variables, in order to reuse the result of an expression.
+
+The returned value is a list of the form
+
+  (let ((<gensym-1> <expr-1>)
+        ...
+        (<gensym-n> <expr-n>))
+    <res>)
+
+where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order
+to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of
+evaluating the implicit progn FORMS within a special context determined by
+SPECS. RES should make use of (reference) the intermediate variables.
+
+Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM).
+Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
+
+Each pair (SYMBOL INITFORM) specifies a single intermediate variable:
+
+- INITFORM is an expression evaluated to produce EXPR-i
+
+- SYMBOL is the name of the variable that will be bound around FORMS to the
+  corresponding gensym GENSYM-i, in order for FORMS to generate RES that
+  references the intermediate variable
+
+The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of
+all the pairs are evaluated before binding SYMBOLs and evaluating FORMS.
+
+Example:
+
+  The following expression
+
+  (let ((x '(incf y)))
+    (once-only (x)
+      `(cons ,x ,x)))
+
+  ;;; =>
+  ;;; (let ((#1=#:X123 (incf y)))
+  ;;;   (cons #1# #1#))
+
+  could be used within a macro to avoid multiple evaluation like so
+
+  (defmacro cons1 (x)
+    (once-only (x)
+      `(cons ,x ,x)))
+
+  (let ((y 0))
+    (cons1 (incf y)))
+
+  ;;; => (1 . 1)
+
+Example:
+
+  The following expression demonstrates the usage of the INITFORM field
+
+  (let ((expr '(incf y)))
+    (once-only ((var `(1+ ,expr)))
+      `(list ',expr ,var ,var)))
+
+  ;;; =>
+  ;;; (let ((#1=#:VAR123 (1+ (incf y))))
+  ;;;   (list '(incf y) #1# #1))
+
+  which could be used like so
+
+  (defmacro print-succ-twice (expr)
+    (once-only ((var `(1+ ,expr)))
+      `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var)))
+
+  (let ((y 10))
+    (print-succ-twice (incf y)))
+
+  ;;; >>
+  ;;; Expr: (INCF Y), Once: 12, Twice: 12"
+  (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+        (names-and-forms (mapcar (lambda (spec)
+                                   (etypecase spec
+                                     (list
+                                      (destructuring-bind (name form) spec
+                                        (cons name form)))
+                                     (symbol
+                                      (cons spec spec))))
+                                 specs)))
+    ;; bind in user-macro
+    `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+                   gensyms names-and-forms)
+       ;; bind in final expansion
+       `(let (,,@(mapcar (lambda (g n)
+                           ``(,,g ,,(cdr n)))
+                         gensyms names-and-forms))
+          ;; bind in user-macro
+          ,(let ,(mapcar (lambda (n g) (list (car n) g))
+                         names-and-forms gensyms)
+             ,@forms)))))
+
+(defun parse-body (body &key documentation whole)
+  "Parses BODY into (values remaining-forms declarations doc-string).
+Documentation strings are recognized only if DOCUMENTATION is true.
+Syntax errors in body are signalled and WHOLE is used in the signal
+arguments when given."
+  (let ((doc nil)
+        (decls nil)
+        (current nil))
+    (tagbody
+     :declarations
+       (setf current (car body))
+       (when (and documentation (stringp current) (cdr body))
+         (if doc
+             (error "Too many documentation strings in ~S." (or whole body))
+             (setf doc (pop body)))
+         (go :declarations))
+       (when (and (listp current) (eql (first current) 'declare))
+         (push (pop body) decls)
+         (go :declarations)))
+    (values body (nreverse decls) doc)))
+
+(defun parse-ordinary-lambda-list (lambda-list &key (normalize t)
+                                   allow-specializers
+                                   (normalize-optional normalize)
+                                   (normalize-keyword normalize)
+                                   (normalize-auxilary normalize))
+  "Parses an ordinary lambda-list, returning as multiple values:
+
+1. Required parameters.
+
+2. Optional parameter specifications, normalized into form:
+
+   (name init suppliedp)
+
+3. Name of the rest parameter, or NIL.
+
+4. Keyword parameter specifications, normalized into form:
+
+   ((keyword-name name) init suppliedp)
+
+5. Boolean indicating &ALLOW-OTHER-KEYS presence.
+
+6. &AUX parameter specifications, normalized into form
+
+   (name init).
+
+7. Existence of &KEY in the lambda-list.
+
+Signals a PROGRAM-ERROR is the lambda-list is malformed."
+  (let ((state :required)
+        (allow-other-keys nil)
+        (auxp nil)
+        (required nil)
+        (optional nil)
+        (rest nil)
+        (keys nil)
+        (keyp nil)
+        (aux nil))
+    (labels ((fail (elt)
+               (simple-program-error "Misplaced ~S in ordinary lambda-list:~%  ~S"
+                                     elt lambda-list))
+             (check-variable (elt what &optional (allow-specializers allow-specializers))
+               (unless (and (or (symbolp elt)
+                                (and allow-specializers
+                                     (consp elt) (= 2 (length elt)) (symbolp (first elt))))
+                            (not (constantp elt)))
+                 (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~%  ~S"
+                                       what elt lambda-list)))
+             (check-spec (spec what)
+               (destructuring-bind (init suppliedp) spec
+                 (declare (ignore init))
+                 (check-variable suppliedp what nil))))
+      (dolist (elt lambda-list)
+        (case elt
+          (&optional
+           (if (eq state :required)
+               (setf state elt)
+               (fail elt)))
+          (&rest
+           (if (member state '(:required &optional))
+               (setf state elt)
+               (fail elt)))
+          (&key
+           (if (member state '(:required &optional :after-rest))
+               (setf state elt)
+               (fail elt))
+           (setf keyp t))
+          (&allow-other-keys
+           (if (eq state '&key)
+               (setf allow-other-keys t
+                     state elt)
+               (fail elt)))
+          (&aux
+           (cond ((eq state '&rest)
+                  (fail elt))
+                 (auxp
+                  (simple-program-error "Multiple ~S in ordinary lambda-list:~%  ~S"
+                                        elt lambda-list))
+                 (t
+                  (setf auxp t
+                        state elt))
+                 ))
+          (otherwise
+           (when (member elt '#.(set-difference lambda-list-keywords
+                                                '(&optional &rest &key &allow-other-keys &aux)))
+             (simple-program-error
+              "Bad lambda-list keyword ~S in ordinary lambda-list:~%  ~S"
+              elt lambda-list))
+           (case state
+             (:required
+              (check-variable elt "required parameter")
+              (push elt required))
+             (&optional
+              (cond ((consp elt)
+                     (destructuring-bind (name &rest tail) elt
+                       (check-variable name "optional parameter")
+                       (cond ((cdr tail)
+                              (check-spec tail "optional-supplied-p parameter"))
+                             ((and normalize-optional tail)
+                              (setf elt (append elt '(nil))))
+                             (normalize-optional
+                              (setf elt (append elt '(nil nil)))))))
+                    (t
+                     (check-variable elt "optional parameter")
+                     (when normalize-optional
+                       (setf elt (cons elt '(nil nil))))))
+              (push (ensure-list elt) optional))
+             (&rest
+              (check-variable elt "rest parameter")
+              (setf rest elt
+                    state :after-rest))
+             (&key
+              (cond ((consp elt)
+                     (destructuring-bind (var-or-kv &rest tail) elt
+                       (cond ((consp var-or-kv)
+                              (destructuring-bind (keyword var) var-or-kv
+                                (unless (symbolp keyword)
+                                  (simple-program-error "Invalid keyword name ~S in ordinary ~
+                                                         lambda-list:~%  ~S"
+                                                        keyword lambda-list))
+                                (check-variable var "keyword parameter")))
+                             (t
+                              (check-variable var-or-kv "keyword parameter")
+                              (when normalize-keyword
+                                (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
+                       (cond ((cdr tail)
+                              (check-spec tail "keyword-supplied-p parameter"))
+                             ((and normalize-keyword tail)
+                              (setf tail (append tail '(nil))))
+                             (normalize-keyword
+                              (setf tail '(nil nil))))
+                       (setf elt (cons var-or-kv tail))))
+                    (t
+                     (check-variable elt "keyword parameter")
+                     (setf elt (if normalize-keyword
+                                   (list (list (make-keyword elt) elt) nil nil)
+                                   elt))))
+              (push elt keys))
+             (&aux
+              (if (consp elt)
+                  (destructuring-bind (var &optional init) elt
+                    (declare (ignore init))
+                    (check-variable var "&aux parameter"))
+                  (progn
+                    (check-variable elt "&aux parameter")
+                    (setf elt (list* elt (when normalize-auxilary
+                                           '(nil))))))
+              (push elt aux))
+             (t
+              (simple-program-error "Invalid ordinary lambda-list:~%  ~S" lambda-list)))))))
+    (values (nreverse required) (nreverse optional) rest (nreverse keys)
+            allow-other-keys (nreverse aux) keyp)))
+
+;;;; DESTRUCTURING-*CASE
+
+(defun expand-destructuring-case (key clauses case)
+  (once-only (key)
+    `(if (typep ,key 'cons)
+         (,case (car ,key)
+           ,@(mapcar (lambda (clause)
+                       (destructuring-bind ((keys . lambda-list) &body body) clause
+                         `(,keys
+                           (destructuring-bind ,lambda-list (cdr ,key)
+                             ,@body))))
+                     clauses))
+         (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
+
+(defmacro destructuring-case (keyform &body clauses)
+  "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
+KEYFORM must evaluate to a CONS.
+
+Clauses are of the form:
+
+  ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
+
+The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
+is selected, and FORMs are then executed with CDR of KEY is destructured and
+bound by the DESTRUCTURING-LAMBDA-LIST.
+
+Example:
+
+ (defun dcase (x)
+   (destructuring-case x
+     ((:foo a b)
+      (format nil \"foo: ~S, ~S\" a b))
+     ((:bar &key a b)
+      (format nil \"bar: ~S, ~S\" a b))
+     (((:alt1 :alt2) a)
+      (format nil \"alt: ~S\" a))
+     ((t &rest rest)
+      (format nil \"unknown: ~S\" rest))))
+
+  (dcase (list :foo 1 2))        ; => \"foo: 1, 2\"
+  (dcase (list :bar :a 1 :b 2))  ; => \"bar: 1, 2\"
+  (dcase (list :alt1 1))         ; => \"alt: 1\"
+  (dcase (list :alt2 2))         ; => \"alt: 2\"
+  (dcase (list :quux 1 2 3))     ; => \"unknown: 1, 2, 3\"
+
+ (defun decase (x)
+   (destructuring-case x
+     ((:foo a b)
+      (format nil \"foo: ~S, ~S\" a b))
+     ((:bar &key a b)
+      (format nil \"bar: ~S, ~S\" a b))
+     (((:alt1 :alt2) a)
+      (format nil \"alt: ~S\" a))))
+
+  (decase (list :foo 1 2))        ; => \"foo: 1, 2\"
+  (decase (list :bar :a 1 :b 2))  ; => \"bar: 1, 2\"
+  (decase (list :alt1 1))         ; => \"alt: 1\"
+  (decase (list :alt2 2))         ; => \"alt: 2\"
+  (decase (list :quux 1 2 3))     ; =| error
+"
+  (expand-destructuring-case keyform clauses 'case))
+
+(defmacro destructuring-ccase (keyform &body clauses)
+  (expand-destructuring-case keyform clauses 'ccase))
+
+(defmacro destructuring-ecase (keyform &body clauses)
+  (expand-destructuring-case keyform clauses 'ecase))
+
+(dolist (name '(destructuring-ccase destructuring-ecase))
+  (setf (documentation name 'function) (documentation 'destructuring-case 'function)))
+
+
+

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/numbers.lisp

@@ -0,0 +1,295 @@
+(in-package :alexandria)
+
+(declaim (inline clamp))
+(defun clamp (number min max)
+  "Clamps the NUMBER into [min, max] range. Returns MIN if NUMBER is lesser then
+MIN and MAX if NUMBER is greater then MAX, otherwise returns NUMBER."
+  (if (< number min)
+      min
+      (if (> number max)
+          max
+          number)))
+
+(defun gaussian-random (&optional min max)
+  "Returns two gaussian random double floats as the primary and secondary value,
+optionally constrained by MIN and MAX. Gaussian random numbers form a standard
+normal distribution around 0.0d0.
+
+Sufficiently positive MIN or negative MAX will cause the algorithm used to
+take a very long time. If MIN is positive it should be close to zero, and
+similarly if MAX is negative it should be close to zero."
+  (macrolet
+      ((valid (x)
+         `(<= (or min ,x) ,x (or max ,x)) ))
+    (labels
+        ((gauss ()
+           (loop
+                 for x1 = (- (random 2.0d0) 1.0d0)
+                 for x2 = (- (random 2.0d0) 1.0d0)
+                 for w = (+ (expt x1 2) (expt x2 2))
+                 when (< w 1.0d0)
+                 do (let ((v (sqrt (/ (* -2.0d0 (log w)) w))))
+                      (return (values (* x1 v) (* x2 v))))))
+         (guard (x)
+           (unless (valid x)
+             (tagbody
+              :retry
+                (multiple-value-bind (x1 x2) (gauss)
+                  (when (valid x1)
+                    (setf x x1)
+                    (go :done))
+                  (when (valid x2)
+                    (setf x x2)
+                    (go :done))
+                  (go :retry))
+              :done))
+           x))
+      (multiple-value-bind
+            (g1 g2) (gauss)
+        (values (guard g1) (guard g2))))))
+
+(declaim (inline iota))
+(defun iota (n &key (start 0) (step 1))
+  "Return a list of n numbers, starting from START (with numeric contagion
+from STEP applied), each consequtive number being the sum of the previous one
+and STEP. START defaults to 0 and STEP to 1.
+
+Examples:
+
+  (iota 4)                      => (0 1 2 3)
+  (iota 3 :start 1 :step 1.0)   => (1.0 2.0 3.0)
+  (iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)
+"
+  (declare (type (integer 0) n) (number start step))
+  (loop ;; KLUDGE: get numeric contagion right for the first element too
+        for i = (+ (- (+ start step) step)) then (+ i step)
+        repeat n
+        collect i))
+
+(declaim (inline map-iota))
+(defun map-iota (function n &key (start 0) (step 1))
+  "Calls FUNCTION with N numbers, starting from START (with numeric contagion
+from STEP applied), each consequtive number being the sum of the previous one
+and STEP. START defaults to 0 and STEP to 1. Returns N.
+
+Examples:
+
+  (map-iota #'print 3 :start 1 :step 1.0) => 3
+    ;;; 1.0
+    ;;; 2.0
+    ;;; 3.0
+"
+  (declare (type (integer 0) n) (number start step))
+  (loop ;; KLUDGE: get numeric contagion right for the first element too
+        for i = (+ start (- step step)) then (+ i step)
+        repeat n
+        do (funcall function i))
+  n)
+
+(declaim (inline lerp))
+(defun lerp (v a b)
+  "Returns the result of linear interpolation between A and B, using the
+interpolation coefficient V."
+  ;; The correct version is numerically stable, at the expense of an
+  ;; extra multiply. See (lerp 0.1 4 25) with (+ a (* v (- b a))). The
+  ;; unstable version can often be converted to a fast instruction on
+  ;; a lot of machines, though this is machine/implementation
+  ;; specific. As alexandria is more about correct code, than
+  ;; efficiency, and we're only talking about a single extra multiply,
+  ;; many would prefer the stable version
+  (+ (* (- 1.0 v) a) (* v b)))
+
+(declaim (inline mean))
+(defun mean (sample)
+  "Returns the mean of SAMPLE. SAMPLE must be a sequence of numbers."
+  (/ (reduce #'+ sample) (length sample)))
+
+(defun median (sample)
+  "Returns median of SAMPLE. SAMPLE must be a sequence of real numbers."
+  ;; Implements and uses the quick-select algorithm to find the median
+  ;; https://en.wikipedia.org/wiki/Quickselect
+
+  (labels ((randint-in-range (start-int end-int)
+             "Returns a random integer in the specified range, inclusive"
+             (+ start-int (random (1+ (- end-int start-int)))))
+           (partition (vec start-i end-i)
+             "Implements the partition function, which performs a partial
+              sort of vec around the (randomly) chosen pivot.
+              Returns the index where the pivot element would be located
+              in a correctly-sorted array"
+             (if (= start-i end-i)
+                 start-i
+                 (let ((pivot-i (randint-in-range start-i end-i)))
+                   (rotatef (aref vec start-i) (aref vec pivot-i))
+                   (let ((swap-i end-i))
+                     (loop for i from swap-i downto (1+ start-i) do
+                       (when (>= (aref vec i) (aref vec start-i))
+                         (rotatef (aref vec i) (aref vec swap-i))
+                         (decf swap-i)))
+                     (rotatef (aref vec swap-i) (aref vec start-i))
+                     swap-i)))))
+
+    (let* ((vector (copy-sequence 'vector sample))
+           (len (length vector))
+           (mid-i (ash len -1))
+           (i 0)
+           (j (1- len)))
+
+      (loop for correct-pos = (partition vector i j)
+            while (/= correct-pos mid-i) do
+              (if (< correct-pos mid-i)
+                  (setf i (1+ correct-pos))
+                  (setf j (1- correct-pos))))
+
+      (if (oddp len)
+          (aref vector mid-i)
+          (* 1/2
+             (+ (aref vector mid-i)
+                (reduce #'max (make-array
+                               mid-i
+                               :displaced-to vector))))))))
+
+(declaim (inline variance))
+(defun variance (sample &key (biased t))
+  "Variance of SAMPLE. Returns the biased variance if BIASED is true (the default),
+and the unbiased estimator of variance if BIASED is false. SAMPLE must be a
+sequence of numbers."
+  (let ((mean (mean sample)))
+    (/ (reduce (lambda (a b)
+                 (+ a (expt (- b mean) 2)))
+               sample
+               :initial-value 0)
+       (- (length sample) (if biased 0 1)))))
+
+(declaim (inline standard-deviation))
+(defun standard-deviation (sample &key (biased t))
+  "Standard deviation of SAMPLE. Returns the biased standard deviation if
+BIASED is true (the default), and the square root of the unbiased estimator
+for variance if BIASED is false (which is not the same as the unbiased
+estimator for standard deviation). SAMPLE must be a sequence of numbers."
+  (sqrt (variance sample :biased biased)))
+
+(define-modify-macro maxf (&rest numbers) max
+  "Modify-macro for MAX. Sets place designated by the first argument to the
+maximum of its original value and NUMBERS.")
+
+(define-modify-macro minf (&rest numbers) min
+  "Modify-macro for MIN. Sets place designated by the first argument to the
+minimum of its original value and NUMBERS.")
+
+;;;; Factorial
+
+;;; KLUDGE: This is really dependant on the numbers in question: for
+;;; small numbers this is larger, and vice versa. Ideally instead of a
+;;; constant we would have RANGE-FAST-TO-MULTIPLY-DIRECTLY-P.
+(defconstant +factorial-bisection-range-limit+ 8)
+
+;;; KLUDGE: This is really platform dependant: ideally we would use
+;;; (load-time-value (find-good-direct-multiplication-limit)) instead.
+(defconstant +factorial-direct-multiplication-limit+ 13)
+
+(defun %multiply-range (i j)
+  ;; We use a a bit of cleverness here:
+  ;;
+  ;; 1. For large factorials we bisect in order to avoid expensive bignum
+  ;;    multiplications: 1 x 2 x 3 x ... runs into bignums pretty soon,
+  ;;    and once it does that all further multiplications will be with bignums.
+  ;;
+  ;;    By instead doing the multiplication in a tree like
+  ;;       ((1 x 2) x (3 x 4)) x ((5 x 6) x (7 x 8))
+  ;;    we manage to get less bignums.
+  ;;
+  ;; 2. Division isn't exactly free either, however, so we don't bisect
+  ;;    all the way down, but multiply ranges of integers close to each
+  ;;    other directly.
+  ;;
+  ;; For even better results it should be possible to use prime
+  ;; factorization magic, but Nikodemus ran out of steam.
+  ;;
+  ;; KLUDGE: We support factorials of bignums, but it seems quite
+  ;; unlikely anyone would ever be able to use them on a modern lisp,
+  ;; since the resulting numbers are unlikely to fit in memory... but
+  ;; it would be extremely unelegant to define FACTORIAL only on
+  ;; fixnums, _and_ on lisps with 16 bit fixnums this can actually be
+  ;; needed.
+  (labels ((bisect (j k)
+             (declare (type (integer 1 #.most-positive-fixnum) j k))
+             (if (< (- k j) +factorial-bisection-range-limit+)
+                 (multiply-range j k)
+                 (let ((middle (+ j (truncate (- k j) 2))))
+                   (* (bisect j middle)
+                      (bisect (+ middle 1) k)))))
+           (bisect-big (j k)
+             (declare (type (integer 1) j k))
+             (if (= j k)
+                 j
+                 (let ((middle (+ j (truncate (- k j) 2))))
+                   (* (if (<= middle most-positive-fixnum)
+                          (bisect j middle)
+                          (bisect-big j middle))
+                      (bisect-big (+ middle 1) k)))))
+           (multiply-range (j k)
+             (declare (type (integer 1 #.most-positive-fixnum) j k))
+             (do ((f k (* f m))
+                  (m (1- k) (1- m)))
+                 ((< m j) f)
+               (declare (type (integer 0 (#.most-positive-fixnum)) m)
+                        (type unsigned-byte f)))))
+    (if (and (typep i 'fixnum) (typep j 'fixnum))
+        (bisect i j)
+        (bisect-big i j))))
+
+(declaim (inline factorial))
+(defun %factorial (n)
+  (if (< n 2)
+      1
+      (%multiply-range 1 n)))
+
+(defun factorial (n)
+  "Factorial of non-negative integer N."
+  (check-type n (integer 0))
+  (%factorial n))
+
+;;;; Combinatorics
+
+(defun binomial-coefficient (n k)
+  "Binomial coefficient of N and K, also expressed as N choose K. This is the
+number of K element combinations given N choises. N must be equal to or
+greater then K."
+  (check-type n (integer 0))
+  (check-type k (integer 0))
+  (assert (>= n k))
+  (if (or (zerop k) (= n k))
+      1
+      (let ((n-k (- n k)))
+        ;; Swaps K and N-K if K < N-K because the algorithm
+        ;; below is faster for bigger K and smaller N-K
+        (when (< k n-k)
+          (rotatef k n-k))
+        (if (= 1 n-k)
+            n
+            ;; General case, avoid computing the 1x...xK twice:
+            ;;
+            ;;    N!           1x...xN          (K+1)x...xN
+            ;; --------  =  ---------------- =  ------------, N>1
+            ;; K!(N-K)!     1x...xK x (N-K)!       (N-K)!
+            (/ (%multiply-range (+ k 1) n)
+               (%factorial n-k))))))
+
+(defun subfactorial (n)
+  "Subfactorial of the non-negative integer N."
+  (check-type n (integer 0))
+  (if (zerop n)
+      1
+      (do ((x 1 (1+ x))
+           (a 0 (* x (+ a b)))
+           (b 1 a))
+          ((= n x) a))))
+
+(defun count-permutations (n &optional (k n))
+  "Number of K element permutations for a sequence of N objects.
+K defaults to N"
+  (check-type n (integer 0))
+  (check-type k (integer 0))
+  (assert (>= n k))
+  (%multiply-range (1+ (- n k)) n))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/package.lisp

@@ -0,0 +1,243 @@
+(defpackage :alexandria.1.0.0
+  (:nicknames :alexandria)
+  (:use :cl)
+  #+sb-package-locks
+  (:lock t)
+  (:export
+   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+   ;; BLESSED
+   ;;
+   ;; Binding constructs
+   #:if-let
+   #:when-let
+   #:when-let*
+   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+   ;; REVIEW IN PROGRESS
+   ;;
+   ;; Control flow
+   ;;
+   ;; -- no clear consensus yet --
+   #:cswitch
+   #:eswitch
+   #:switch
+   ;; -- problem free? --
+   #:multiple-value-prog2
+   #:nth-value-or
+   #:whichever
+   #:xor
+   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+   ;; REVIEW PENDING
+   ;;
+   ;; Definitions
+   #:define-constant
+   ;; Hash tables
+   #:alist-hash-table
+   #:copy-hash-table
+   #:ensure-gethash
+   #:hash-table-alist
+   #:hash-table-keys
+   #:hash-table-plist
+   #:hash-table-values
+   #:maphash-keys
+   #:maphash-values
+   #:plist-hash-table
+   ;; Functions
+   #:compose
+   #:conjoin
+   #:curry
+   #:disjoin
+   #:ensure-function
+   #:ensure-functionf
+   #:multiple-value-compose
+   #:named-lambda
+   #:rcurry
+   ;; Lists
+   #:alist-plist
+   #:appendf
+   #:nconcf
+   #:reversef
+   #:nreversef
+   #:circular-list
+   #:circular-list-p
+   #:circular-tree-p
+   #:doplist
+   #:ensure-car
+   #:ensure-cons
+   #:ensure-list
+   #:flatten
+   #:lastcar
+   #:make-circular-list
+   #:map-product
+   #:mappend
+   #:nunionf
+   #:plist-alist
+   #:proper-list
+   #:proper-list-length
+   #:proper-list-p
+   #:remove-from-plist
+   #:remove-from-plistf
+   #:delete-from-plist
+   #:delete-from-plistf
+   #:set-equal
+   #:setp
+   #:unionf
+   ;; Numbers
+   #:binomial-coefficient
+   #:clamp
+   #:count-permutations
+   #:factorial
+   #:gaussian-random
+   #:iota
+   #:lerp
+   #:map-iota
+   #:maxf
+   #:mean
+   #:median
+   #:minf
+   #:standard-deviation
+   #:subfactorial
+   #:variance
+   ;; Arrays
+   #:array-index
+   #:array-length
+   #:copy-array
+   ;; Sequences
+   #:copy-sequence
+   #:deletef
+   #:emptyp
+   #:ends-with
+   #:ends-with-subseq
+   #:extremum
+   #:first-elt
+   #:last-elt
+   #:length=
+   #:map-combinations
+   #:map-derangements
+   #:map-permutations
+   #:proper-sequence
+   #:random-elt
+   #:removef
+   #:rotate
+   #:sequence-of-length-p
+   #:shuffle
+   #:starts-with
+   #:starts-with-subseq
+   ;; Macros
+   #:once-only
+   #:parse-body
+   #:parse-ordinary-lambda-list
+   #:with-gensyms
+   #:with-unique-names
+   ;; Symbols
+   #:ensure-symbol
+   #:format-symbol
+   #:make-gensym
+   #:make-gensym-list
+   #:make-keyword
+   ;; Strings
+   #:string-designator
+   ;; Types
+   #:negative-double-float
+   #:negative-fixnum-p
+   #:negative-float
+   #:negative-float-p
+   #:negative-long-float
+   #:negative-long-float-p
+   #:negative-rational
+   #:negative-rational-p
+   #:negative-real
+   #:negative-single-float-p
+   #:non-negative-double-float
+   #:non-negative-double-float-p
+   #:non-negative-fixnum
+   #:non-negative-fixnum-p
+   #:non-negative-float
+   #:non-negative-float-p
+   #:non-negative-integer-p
+   #:non-negative-long-float
+   #:non-negative-rational
+   #:non-negative-real-p
+   #:non-negative-short-float-p
+   #:non-negative-single-float
+   #:non-negative-single-float-p
+   #:non-positive-double-float
+   #:non-positive-double-float-p
+   #:non-positive-fixnum
+   #:non-positive-fixnum-p
+   #:non-positive-float
+   #:non-positive-float-p
+   #:non-positive-integer
+   #:non-positive-rational
+   #:non-positive-real
+   #:non-positive-real-p
+   #:non-positive-short-float
+   #:non-positive-short-float-p
+   #:non-positive-single-float-p
+   #:positive-double-float
+   #:positive-double-float-p
+   #:positive-fixnum
+   #:positive-fixnum-p
+   #:positive-float
+   #:positive-float-p
+   #:positive-integer
+   #:positive-rational
+   #:positive-real
+   #:positive-real-p
+   #:positive-short-float
+   #:positive-short-float-p
+   #:positive-single-float
+   #:positive-single-float-p
+   #:coercef
+   #:negative-double-float-p
+   #:negative-fixnum
+   #:negative-integer
+   #:negative-integer-p
+   #:negative-real-p
+   #:negative-short-float
+   #:negative-short-float-p
+   #:negative-single-float
+   #:non-negative-integer
+   #:non-negative-long-float-p
+   #:non-negative-rational-p
+   #:non-negative-real
+   #:non-negative-short-float
+   #:non-positive-integer-p
+   #:non-positive-long-float
+   #:non-positive-long-float-p
+   #:non-positive-rational-p
+   #:non-positive-single-float
+   #:of-type
+   #:positive-integer-p
+   #:positive-long-float
+   #:positive-long-float-p
+   #:positive-rational-p
+   #:type=
+   ;; Conditions
+   #:required-argument
+   #:ignore-some-conditions
+   #:simple-style-warning
+   #:simple-reader-error
+   #:simple-parse-error
+   #:simple-program-error
+   #:unwind-protect-case
+   ;; Features
+   #:featurep
+   ;; io
+   #:with-input-from-file
+   #:with-output-to-file
+   #:read-stream-content-into-string
+   #:read-file-into-string
+   #:write-string-into-file
+   #:read-stream-content-into-byte-vector
+   #:read-file-into-byte-vector
+   #:write-byte-vector-into-file
+   #:copy-stream
+   #:copy-file
+   ;; new additions collected at the end (subject to removal or further changes)
+   #:symbolicate
+   #:assoc-value
+   #:rassoc-value
+   #:destructuring-case
+   #:destructuring-ccase
+   #:destructuring-ecase
+   ))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/sequences.lisp

@@ -0,0 +1,555 @@
+(in-package :alexandria)
+
+;; Make these inlinable by declaiming them INLINE here and some of them
+;; NOTINLINE at the end of the file. Exclude functions that have a compiler
+;; macro, because NOTINLINE is required to prevent compiler-macro expansion.
+(declaim (inline copy-sequence sequence-of-length-p))
+
+(defun sequence-of-length-p (sequence length)
+  "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
+SEQUENCE is not a sequence. Returns FALSE for circular lists."
+  (declare (type array-index length)
+           #-lispworks (inline length)
+           (optimize speed))
+  (etypecase sequence
+    (null
+     (zerop length))
+    (cons
+     (let ((n (1- length)))
+       (unless (minusp n)
+         (let ((tail (nthcdr n sequence)))
+           (and tail
+                (null (cdr tail)))))))
+    (vector
+     (= length (length sequence)))
+    (sequence
+     (= length (length sequence)))))
+
+(defun rotate-tail-to-head (sequence n)
+  (declare (type (integer 1) n))
+  (if (listp sequence)
+      (let ((m (mod n (proper-list-length sequence))))
+        (if (null (cdr sequence))
+            sequence
+            (let* ((tail (last sequence (+ m 1)))
+                   (last (cdr tail)))
+              (setf (cdr tail) nil)
+              (nconc last sequence))))
+      (let* ((len (length sequence))
+             (m (mod n len))
+             (tail (subseq sequence (- len m))))
+        (replace sequence sequence :start1 m :start2 0)
+        (replace sequence tail)
+        sequence)))
+
+(defun rotate-head-to-tail (sequence n)
+  (declare (type (integer 1) n))
+  (if (listp sequence)
+      (let ((m (mod (1- n) (proper-list-length sequence))))
+        (if (null (cdr sequence))
+            sequence
+            (let* ((headtail (nthcdr m sequence))
+                   (tail (cdr headtail)))
+              (setf (cdr headtail) nil)
+              (nconc tail sequence))))
+      (let* ((len (length sequence))
+             (m (mod n len))
+             (head (subseq sequence 0 m)))
+        (replace sequence sequence :start1 0 :start2 m)
+        (replace sequence head :start1 (- len m))
+        sequence)))
+
+(defun rotate (sequence &optional (n 1))
+  "Returns a sequence of the same type as SEQUENCE, with the elements of
+SEQUENCE rotated by N: N elements are moved from the end of the sequence to
+the front if N is positive, and -N elements moved from the front to the end if
+N is negative. SEQUENCE must be a proper sequence. N must be an integer,
+defaulting to 1.
+
+If absolute value of N is greater then the length of the sequence, the results
+are identical to calling ROTATE with
+
+  (* (signum n) (mod n (length sequence))).
+
+Note: the original sequence may be destructively altered, and result sequence may
+share structure with it."
+  (if (plusp n)
+      (rotate-tail-to-head sequence n)
+      (if (minusp n)
+          (rotate-head-to-tail sequence (- n))
+          sequence)))
+
+(defun shuffle (sequence &key (start 0) end)
+  "Returns a random permutation of SEQUENCE bounded by START and END.
+Original sequence may be destructively modified, and (if it contains
+CONS or lists themselv) share storage with the original one.
+Signals an error if SEQUENCE is not a proper sequence."
+  (declare (type fixnum start)
+           (type (or fixnum null) end))
+  (etypecase sequence
+    (list
+     (let* ((end (or end (proper-list-length sequence)))
+            (n (- end start)))
+       (do ((tail (nthcdr start sequence) (cdr tail)))
+           ((zerop n))
+         (rotatef (car tail) (car (nthcdr (random n) tail)))
+         (decf n))))
+    (vector
+     (let ((end (or end (length sequence))))
+       (loop for i from start below end
+             do (rotatef (aref sequence i)
+                         (aref sequence (+ i (random (- end i))))))))
+    (sequence
+     (let ((end (or end (length sequence))))
+       (loop for i from (- end 1) downto start
+             do (rotatef (elt sequence i)
+                         (elt sequence (+ i (random (- end i)))))))))
+  sequence)
+
+(defun random-elt (sequence &key (start 0) end)
+  "Returns a random element from SEQUENCE bounded by START and END. Signals an
+error if the SEQUENCE is not a proper non-empty sequence, or if END and START
+are not proper bounding index designators for SEQUENCE."
+  (declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
+  (let* ((size (if (listp sequence)
+                   (proper-list-length sequence)
+                   (length sequence)))
+         (end2 (or end size)))
+    (cond ((zerop size)
+           (error 'type-error
+                  :datum sequence
+                  :expected-type `(and sequence (not (satisfies emptyp)))))
+          ((not (and (<= 0 start) (< start end2) (<= end2 size)))
+           (error 'simple-type-error
+                  :datum (cons start end)
+                  :expected-type `(cons (integer 0 (,end2))
+                                        (or null (integer (,start) ,size)))
+                  :format-control "~@<~S and ~S are not valid bounding index designators for ~
+                                   a sequence of length ~S.~:@>"
+                  :format-arguments (list start end size)))
+          (t
+           (let ((index (+ start (random (- end2 start)))))
+             (elt sequence index))))))
+
+(declaim (inline remove/swapped-arguments))
+(defun remove/swapped-arguments (sequence item &rest keyword-arguments)
+  (apply #'remove item sequence keyword-arguments))
+
+(define-modify-macro removef (item &rest keyword-arguments)
+  remove/swapped-arguments
+  "Modify-macro for REMOVE. Sets place designated by the first argument to
+the result of calling REMOVE with ITEM, place, and the KEYWORD-ARGUMENTS.")
+
+(declaim (inline delete/swapped-arguments))
+(defun delete/swapped-arguments (sequence item &rest keyword-arguments)
+  (apply #'delete item sequence keyword-arguments))
+
+(define-modify-macro deletef (item &rest keyword-arguments)
+  delete/swapped-arguments
+  "Modify-macro for DELETE. Sets place designated by the first argument to
+the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS.")
+
+(deftype proper-sequence ()
+  "Type designator for proper sequences, that is proper lists and sequences
+that are not lists."
+  `(or proper-list
+       (and (not list) sequence)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (and (find-package '#:sequence)
+             (find-symbol (string '#:emptyp) '#:sequence))
+    (pushnew 'sequence-emptyp *features*)))
+
+#-alexandria::sequence-emptyp
+(defun emptyp (sequence)
+  "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
+is not a sequence."
+  (etypecase sequence
+    (list (null sequence))
+    (sequence (zerop (length sequence)))))
+
+#+alexandria::sequence-emptyp
+(declaim (ftype (function (sequence) (values boolean &optional)) emptyp))
+#+alexandria::sequence-emptyp
+(setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp))
+#+alexandria::sequence-emptyp
+(define-compiler-macro emptyp (sequence)
+  `(sequence:emptyp ,sequence))
+
+(defun length= (&rest sequences)
+  "Takes any number of sequences or integers in any order. Returns true iff
+the length of all the sequences and the integers are equal. Hint: there's a
+compiler macro that expands into more efficient code if the first argument
+is a literal integer."
+  (declare (dynamic-extent sequences)
+           (inline sequence-of-length-p)
+           (optimize speed))
+  (unless (cdr sequences)
+    (error "You must call LENGTH= with at least two arguments"))
+  ;; There's room for optimization here: multiple list arguments could be
+  ;; traversed in parallel.
+  (let* ((first (pop sequences))
+         (current (if (integerp first)
+                      first
+                      (length first))))
+    (declare (type array-index current))
+    (dolist (el sequences)
+      (if (integerp el)
+          (unless (= el current)
+            (return-from length= nil))
+          (unless (sequence-of-length-p el current)
+            (return-from length= nil)))))
+  t)
+
+(define-compiler-macro length= (&whole form length &rest sequences)
+  (cond
+    ((zerop (length sequences))
+     form)
+    (t
+     (let ((optimizedp (integerp length)))
+       (with-unique-names (tmp current)
+         (declare (ignorable current))
+         `(locally
+              (declare (inline sequence-of-length-p))
+            (let ((,tmp)
+                  ,@(unless optimizedp
+                     `((,current ,length))))
+              ,@(unless optimizedp
+                  `((unless (integerp ,current)
+                      (setf ,current (length ,current)))))
+              (and
+               ,@(loop
+                    :for sequence :in sequences
+                    :collect `(progn
+                                (setf ,tmp ,sequence)
+                                (if (integerp ,tmp)
+                                    (= ,tmp ,(if optimizedp
+                                                 length
+                                                 current))
+                                    (sequence-of-length-p ,tmp ,(if optimizedp
+                                                                    length
+                                                                    current)))))))))))))
+
+(defun copy-sequence (type sequence)
+  "Returns a fresh sequence of TYPE, which has the same elements as
+SEQUENCE."
+  (if (typep sequence type)
+      (copy-seq sequence)
+      (coerce sequence type)))
+
+(defun first-elt (sequence)
+  "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a sequence, or is an empty sequence."
+  ;; Can't just directly use ELT, as it is not guaranteed to signal the
+  ;; type-error.
+  (cond  ((consp sequence)
+          (car sequence))
+         ((and (typep sequence 'sequence) (not (emptyp sequence)))
+          (elt sequence 0))
+         (t
+          (error 'type-error
+                 :datum sequence
+                 :expected-type '(and sequence (not (satisfies emptyp)))))))
+
+(defun (setf first-elt) (object sequence)
+  "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
+  ;; Can't just directly use ELT, as it is not guaranteed to signal the
+  ;; type-error.
+  (cond ((consp sequence)
+         (setf (car sequence) object))
+        ((and (typep sequence 'sequence) (not (emptyp sequence)))
+         (setf (elt sequence 0) object))
+        (t
+         (error 'type-error
+                :datum sequence
+                :expected-type '(and sequence (not (satisfies emptyp)))))))
+
+(defun last-elt (sequence)
+  "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a proper sequence, or is an empty sequence."
+  ;; Can't just directly use ELT, as it is not guaranteed to signal the
+  ;; type-error.
+  (let ((len 0))
+    (cond ((consp sequence)
+           (lastcar sequence))
+          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
+           (elt sequence (1- len)))
+          (t
+           (error 'type-error
+                  :datum sequence
+                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
+
+(defun (setf last-elt) (object sequence)
+  "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
+sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
+  (let ((len 0))
+    (cond ((consp sequence)
+           (setf (lastcar sequence) object))
+          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
+           (setf (elt sequence (1- len)) object))
+          (t
+           (error 'type-error
+                  :datum sequence
+                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
+
+(defun starts-with-subseq (prefix sequence &rest args
+                           &key
+                           (return-suffix nil return-suffix-supplied-p)
+                           &allow-other-keys)
+  "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
+
+If RETURN-SUFFIX is T the function returns, as a second value, a
+sub-sequence or displaced array pointing to the sequence after PREFIX."
+  (declare (dynamic-extent args))
+  (let ((sequence-length (length sequence))
+        (prefix-length (length prefix)))
+    (when (< sequence-length prefix-length)
+      (return-from starts-with-subseq (values nil nil)))
+    (flet ((make-suffix (start)
+             (when return-suffix
+               (cond
+                 ((not (arrayp sequence))
+                  (if start
+                      (subseq sequence start)
+                      (subseq sequence 0 0)))
+                 ((not start)
+                  (make-array 0
+                              :element-type (array-element-type sequence)
+                              :adjustable nil))
+                 (t
+                  (make-array (- sequence-length start)
+                              :element-type (array-element-type sequence)
+                              :displaced-to sequence
+                              :displaced-index-offset start
+                              :adjustable nil))))))
+      (let ((mismatch (apply #'mismatch prefix sequence
+                             (if return-suffix-supplied-p
+                                 (remove-from-plist args :return-suffix)
+                                 args))))
+        (cond
+          ((not mismatch)
+           (values t (make-suffix nil)))
+          ((= mismatch prefix-length)
+           (values t (make-suffix mismatch)))
+          (t
+           (values nil nil)))))))
+
+(defun ends-with-subseq (suffix sequence &key (test #'eql))
+  "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
+the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
+  (let ((sequence-length (length sequence))
+        (suffix-length (length suffix)))
+    (when (< sequence-length suffix-length)
+      ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
+      (return-from ends-with-subseq nil))
+    (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
+          for suffix-index from 0 below suffix-length
+          when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
+          do (return-from ends-with-subseq nil)
+          finally (return t))))
+
+(defun starts-with (object sequence &key (test #'eql) (key #'identity))
+  "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
+Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
+  (let ((first-elt (typecase sequence
+                     (cons (car sequence))
+                     (sequence
+                      (if (emptyp sequence)
+                          (return-from starts-with nil)
+                          (elt sequence 0)))
+                     (t
+                      (return-from starts-with nil)))))
+    (funcall test (funcall key first-elt) object)))
+
+(defun ends-with (object sequence &key (test #'eql) (key #'identity))
+  "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
+Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
+an error if SEQUENCE is an improper list."
+  (let ((last-elt (typecase sequence
+                    (cons
+                     (lastcar sequence)) ; signals for improper lists
+                    (sequence
+                     ;; Can't use last-elt, as that signals an error
+                     ;; for empty sequences
+                     (let ((len (length sequence)))
+                       (if (plusp len)
+                           (elt sequence (1- len))
+                           (return-from ends-with nil))))
+                    (t
+                     (return-from ends-with nil)))))
+    (funcall test (funcall key last-elt) object)))
+
+(defun map-combinations (function sequence &key (start 0) end length (copy t))
+  "Calls FUNCTION with each combination of LENGTH constructable from the
+elements of the subsequence of SEQUENCE delimited by START and END. START
+defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
+delimited subsequence. (So unless LENGTH is specified there is only a single
+combination, which has the same elements as the delimited subsequence.) If
+COPY is true (the default) each combination is freshly allocated. If COPY is
+false all combinations are EQ to each other, in which case consequences are
+unspecified if a combination is modified by FUNCTION."
+  (let* ((end (or end (length sequence)))
+         (size (- end start))
+         (length (or length size))
+         (combination (subseq sequence 0 length))
+         (function (ensure-function function)))
+    (if (= length size)
+        (funcall function combination)
+        (flet ((call ()
+                 (funcall function (if copy
+                                       (copy-seq combination)
+                                       combination))))
+          (etypecase sequence
+            ;; When dealing with lists we prefer walking back and
+            ;; forth instead of using indexes.
+            (list
+             (labels ((combine-list (c-tail o-tail)
+                        (if (not c-tail)
+                            (call)
+                            (do ((tail o-tail (cdr tail)))
+                                ((not tail))
+                              (setf (car c-tail) (car tail))
+                              (combine-list (cdr c-tail) (cdr tail))))))
+               (combine-list combination (nthcdr start sequence))))
+            (vector
+             (labels ((combine (count start)
+                        (if (zerop count)
+                            (call)
+                            (loop for i from start below end
+                                  do (let ((j (- count 1)))
+                                       (setf (aref combination j) (aref sequence i))
+                                       (combine j (+ i 1)))))))
+               (combine length start)))
+            (sequence
+             (labels ((combine (count start)
+                        (if (zerop count)
+                            (call)
+                            (loop for i from start below end
+                                  do (let ((j (- count 1)))
+                                       (setf (elt combination j) (elt sequence i))
+                                       (combine j (+ i 1)))))))
+               (combine length start)))))))
+  sequence)
+
+(defun map-permutations (function sequence &key (start 0) end length (copy t))
+  "Calls function with each permutation of LENGTH constructable
+from the subsequence of SEQUENCE delimited by START and END. START
+defaults to 0, END to length of the sequence, and LENGTH to the
+length of the delimited subsequence."
+  (let* ((end (or end (length sequence)))
+         (size (- end start))
+         (length (or length size)))
+    (labels ((permute (seq n)
+               (let ((n-1 (- n 1)))
+                 (if (zerop n-1)
+                     (funcall function (if copy
+                                           (copy-seq seq)
+                                           seq))
+                     (loop for i from 0 upto n-1
+                           do (permute seq n-1)
+                           (if (evenp n-1)
+                               (rotatef (elt seq 0) (elt seq n-1))
+                               (rotatef (elt seq i) (elt seq n-1)))))))
+             (permute-sequence (seq)
+               (permute seq length)))
+      (if (= length size)
+          ;; Things are simple if we need to just permute the
+          ;; full START-END range.
+          (permute-sequence (subseq sequence start end))
+          ;; Otherwise we need to generate all the combinations
+          ;; of LENGTH in the START-END range, and then permute
+          ;; a copy of the result: can't permute the combination
+          ;; directly, as they share structure with each other.
+          (let ((permutation (subseq sequence 0 length)))
+            (flet ((permute-combination (combination)
+                     (permute-sequence (replace permutation combination))))
+              (declare (dynamic-extent #'permute-combination))
+              (map-combinations #'permute-combination sequence
+                                :start start
+                                :end end
+                                :length length
+                                :copy nil)))))))
+
+(defun map-derangements (function sequence &key (start 0) end (copy t))
+  "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
+by the bounding index designators START and END. Derangement is a permutation
+of the sequence where no element remains in place. SEQUENCE is not modified,
+but individual derangements are EQ to each other. Consequences are unspecified
+if calling FUNCTION modifies either the derangement or SEQUENCE."
+  (let* ((end (or end (length sequence)))
+         (size (- end start))
+         ;; We don't really care about the elements here.
+         (derangement (subseq sequence 0 size))
+         ;; Bitvector that has 1 for elements that have been deranged.
+         (mask (make-array size :element-type 'bit :initial-element 0)))
+    (declare (dynamic-extent mask))
+    ;; ad hoc algorith
+    (labels ((derange (place n)
+               ;; Perform one recursive step in deranging the
+               ;; sequence: PLACE is index of the original sequence
+               ;; to derange to another index, and N is the number of
+               ;; indexes not yet deranged.
+               (if (zerop n)
+                   (funcall function (if copy
+                                         (copy-seq derangement)
+                                         derangement))
+                   ;; Itarate over the indexes I of the subsequence to
+                   ;; derange: if I != PLACE and I has not yet been
+                   ;; deranged by an earlier call put the element from
+                   ;; PLACE to I, mark I as deranged, and recurse,
+                   ;; finally removing the mark.
+                   (loop for i from 0 below size
+                         do
+                         (unless (or (= place (+ i start)) (not (zerop (bit mask i))))
+                           (setf (elt derangement i) (elt sequence place)
+                                 (bit mask i) 1)
+                           (derange (1+ place) (1- n))
+                           (setf (bit mask i) 0))))))
+      (derange start size)
+      sequence)))
+
+(declaim (notinline sequence-of-length-p))
+
+(defun extremum (sequence predicate &key key (start 0) end)
+  "Returns the element of SEQUENCE that would appear first if the subsequence
+bounded by START and END was sorted using PREDICATE and KEY.
+
+EXTREMUM determines the relationship between two elements of SEQUENCE by using
+the PREDICATE function. PREDICATE should return true if and only if the first
+argument is strictly less than the second one (in some appropriate sense). Two
+arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y)
+and (FUNCALL PREDICATE Y X) are both false.
+
+The arguments to the PREDICATE function are computed from elements of SEQUENCE
+using the KEY function, if supplied. If KEY is not supplied or is NIL, the
+sequence element itself is used.
+
+If SEQUENCE is empty, NIL is returned."
+  (let* ((pred-fun (ensure-function predicate))
+         (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
+                    (ensure-function key)))
+         (real-end (or end (length sequence))))
+    (cond ((> real-end start)
+           (if key-fun
+               (flet ((reduce-keys (a b)
+                        (if (funcall pred-fun
+                                     (funcall key-fun a)
+                                     (funcall key-fun b))
+                            a
+                            b)))
+                 (declare (dynamic-extent #'reduce-keys))
+                 (reduce #'reduce-keys sequence :start start :end real-end))
+               (flet ((reduce-elts (a b)
+                        (if (funcall pred-fun a b)
+                            a
+                            b)))
+                 (declare (dynamic-extent #'reduce-elts))
+                 (reduce #'reduce-elts sequence :start start :end real-end))))
+          ((= real-end start)
+           nil)
+          (t
+           (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
+                  (length sequence)
+                  :start start
+                  :end end)))))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/strings.lisp

@@ -0,0 +1,6 @@
+(in-package :alexandria)
+
+(deftype string-designator ()
+  "A string designator type. A string designator is either a string, a symbol,
+or a character."
+  `(or symbol string character))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/symbols.lisp

@@ -0,0 +1,65 @@
+(in-package :alexandria)
+
+(declaim (inline ensure-symbol))
+(defun ensure-symbol (name &optional (package *package*))
+  "Returns a symbol with name designated by NAME, accessible in package
+designated by PACKAGE. If symbol is not already accessible in PACKAGE, it is
+interned there. Returns a secondary value reflecting the status of the symbol
+in the package, which matches the secondary return value of INTERN.
+
+Example:
+
+  (ensure-symbol :cons :cl) => cl:cons, :external
+"
+  (intern (string name) package))
+
+(defun maybe-intern (name package)
+  (values
+   (if package
+       (intern name (if (eq t package) *package* package))
+       (make-symbol name))))
+
+(declaim (inline format-symbol))
+(defun format-symbol (package control &rest arguments)
+  "Constructs a string by applying ARGUMENTS to string designator CONTROL as
+if by FORMAT within WITH-STANDARD-IO-SYNTAX, and then creates a symbol named
+by that string.
+
+If PACKAGE is NIL, returns an uninterned symbol, if package is T, returns a
+symbol interned in the current package, and otherwise returns a symbol
+interned in the package designated by PACKAGE."
+  (maybe-intern (with-standard-io-syntax
+                  (apply #'format nil (string control) arguments))
+                package))
+
+(defun make-keyword (name)
+  "Interns the string designated by NAME in the KEYWORD package."
+  (intern (string name) :keyword))
+
+(defun make-gensym (name)
+  "If NAME is a non-negative integer, calls GENSYM using it. Otherwise NAME
+must be a string designator, in which case calls GENSYM using the designated
+string as the argument."
+  (gensym (if (typep name '(integer 0))
+              name
+              (string name))))
+
+(defun make-gensym-list (length &optional (x "G"))
+  "Returns a list of LENGTH gensyms, each generated as if with a call to MAKE-GENSYM,
+using the second (optional, defaulting to \"G\") argument."
+  (let ((g (if (typep x '(integer 0)) x (string x))))
+    (loop repeat length
+          collect (gensym g))))
+
+(defun symbolicate (&rest things)
+  "Concatenate together the names of some strings and symbols,
+producing a symbol in the current package."
+  (let* ((length (reduce #'+ things
+                         :key (lambda (x) (length (string x)))))
+         (name (make-array length :element-type 'character)))
+    (let ((index 0))
+      (dolist (thing things (values (intern name)))
+        (let* ((x (string thing))
+               (len (length x)))
+          (replace name x :start1 index)
+          (incf index len))))))

sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/types.lisp

@@ -0,0 +1,137 @@
+(in-package :alexandria)
+
+(deftype array-index (&optional (length (1- array-dimension-limit)))
+  "Type designator for an index into array of LENGTH: an integer between
+0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than
+ARRAY-DIMENSION-LIMIT."
+  `(integer 0 (,length)))
+
+(deftype array-length (&optional (length (1- array-dimension-limit)))
+  "Type designator for a dimension of an array of LENGTH: an integer between
+0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than
+ARRAY-DIMENSION-LIMIT."
+  `(integer 0 ,length))
+
+;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/)
+;; except the RATIO related definitions and ARRAY-INDEX.
+(macrolet
+    ((frob (type &optional (base-type type))
+       (let ((subtype-names (list))
+             (predicate-names (list)))
+         (flet ((make-subtype-name (format-control)
+                  (let ((result (format-symbol :alexandria format-control
+                                               (symbol-name type))))
+                    (push result subtype-names)
+                    result))
+                (make-predicate-name (sybtype-name)
+                  (let ((result (format-symbol :alexandria '#:~A-p
+                                               (symbol-name sybtype-name))))
+                    (push result predicate-names)
+                    result))
+		(make-docstring (range-beg range-end range-type)
+		  (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf"))))
+		    (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A."
+			    type
+			    (if (equal range-beg ''*) inf (ensure-car range-beg))
+			    (if (equal range-end ''*) inf (ensure-car range-end))))))
+           (let* ((negative-name     (make-subtype-name '#:negative-~a))
+                  (non-positive-name (make-subtype-name '#:non-positive-~a))
+                  (non-negative-name (make-subtype-name '#:non-negative-~a))
+                  (positive-name     (make-subtype-name '#:positive-~a))
+                  (negative-p-name     (make-predicate-name negative-name))
+                  (non-positive-p-name (make-predicate-name non-positive-name))
+                  (non-negative-p-name (make-predicate-name non-negative-name))
+                  (positive-p-name     (make-predicate-name positive-name))
+                  (negative-extremum)
+                  (positive-extremum)
+                  (below-zero)
+                  (above-zero)
+                  (zero))
+             (setf (values negative-extremum below-zero
+                           above-zero positive-extremum zero)
+                   (ecase type
+                     (fixnum       (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0))
+                     (integer      (values ''* -1       1        ''* 0))
+                     (rational     (values ''* '(0)     '(0)     ''* 0))
+                     (real         (values ''* '(0)     '(0)     ''* 0))
+                     (float        (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0))
+                     (short-float  (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0))
+                     (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0))
+                     (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0))
+                     (long-float   (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0))))
+             `(progn
+                (deftype ,negative-name ()
+		  ,(make-docstring negative-extremum below-zero :negative)
+		  `(,',base-type ,,negative-extremum ,',below-zero))
+
+                (deftype ,non-positive-name ()
+		  ,(make-docstring negative-extremum zero :negative)
+		  `(,',base-type ,,negative-extremum ,',zero))
+
+                (deftype ,non-negative-name ()
+		  ,(make-docstring zero positive-extremum :positive)
+		  `(,',base-type ,',zero ,,positive-extremum))
+
+                (deftype ,positive-name ()
+		  ,(make-docstring above-zero positive-extremum :positive)
+		  `(,',base-type ,',above-zero ,,positive-extremum))
+
+                (declaim (inline ,@predicate-names))
+
+                (defun ,negative-p-name (n)
+                  (and (typep n ',type)
+                       (< n ,zero)))
+
+                (defun ,non-positive-p-name (n)
+                  (and (typep n ',type)
+                       (<= n ,zero)))
+
+                (defun ,non-negative-p-name (n)
+                  (and (typep n ',type)
+                       (<= ,zero n)))
+
+                (defun ,positive-p-name (n)
+                  (and (typep n ',type)
+                       (< ,zero n)))))))))
+  (frob fixnum integer)
+  (frob integer)
+  (frob rational)
+  (frob real)
+  (frob float)
+  (frob short-float)
+  (frob single-float)
+  (frob double-float)
+  (frob long-float))
+
+(defun of-type (type)
+  "Returns a function of one argument, which returns true when its argument is
+of TYPE."
+  (lambda (thing) (typep thing type)))
+
+(define-compiler-macro of-type (&whole form type &environment env)
+  ;; This can yeild a big benefit, but no point inlining the function
+  ;; all over the place if TYPE is not constant.
+  (if (constantp type env)
+      (with-gensyms (thing)
+        `(lambda (,thing)
+           (typep ,thing ,type)))
+      form))
+
+(declaim (inline type=))
+(defun type= (type1 type2)
+  "Returns a primary value of T is TYPE1 and TYPE2 are the same type,
+and a secondary value that is true is the type equality could be reliably
+determined: primary value of NIL and secondary value of T indicates that the
+types are not equivalent."
+  (multiple-value-bind (sub ok) (subtypep type1 type2)
+    (cond ((and ok sub)
+           (subtypep type2 type1))
+          (ok
+           (values nil ok))
+          (t
+           (multiple-value-bind (sub ok) (subtypep type2 type1)
+             (declare (ignore sub))
+             (values nil ok))))))
+
+(define-modify-macro coercef (type-spec) coerce
+  "Modify-macro for COERCE.")

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/.gitref

@@ -0,0 +1 @@
+c1f15e2bd02fabe7bb468b05fe311cd9a932f14f

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/.travis.yml

@@ -0,0 +1,41 @@
+language: emacs
+
+env:
+  # we test emacs23 with sbcl only
+  - "CHECK_TARGET=check       LISP=sbcl EMACS=emacs23"
+  - "CHECK_TARGET=check-fancy LISP=sbcl EMACS=emacs23"
+
+  # for emacs24, use more combinations
+  - "CHECK_TARGET=check       LISP=sbcl  EMACS=emacs24"
+  #- "CHECK_TARGET=check       LISP=cmucl EMACS=emacs24"
+  - "CHECK_TARGET=check       LISP=ccl   EMACS=emacs24"
+  - "CHECK_TARGET=check-fancy LISP=sbcl  EMACS=emacs24"
+  #- "CHECK_TARGET=check-fancy LISP=cmucl EMACS=emacs24"
+  - "CHECK_TARGET=check-fancy LISP=ccl   EMACS=emacs24"
+
+  # also, for emacs24/sbcl test some more contribs in isolation
+  - "CHECK_TARGET=check-repl LISP=sbcl EMACS=emacs24"
+  - "CHECK_TARGET=check-indentation LISP=sbcl EMACS=emacs24"
+
+install:
+  - curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | bash
+  - if [ "$EMACS" = "emacs23" ]; then
+        sudo apt-get -qq update &&
+        sudo apt-get -qq -f install &&
+        sudo apt-get -qq install emacs23-nox;
+    fi
+  - if [ "$EMACS" = "emacs24" ]; then
+        sudo add-apt-repository -y ppa:cassou/emacs &&
+        sudo apt-get -qq update &&
+        sudo apt-get -qq -f install &&
+        sudo apt-get -qq install emacs24-nox;
+    fi
+
+script:
+  - make LISP=$LISP EMACS=$EMACS $CHECK_TARGET
+
+notifications:
+  email:
+    recipients:
+      - slime-cvs@common-lisp.net
+    # on_success: always # for testing

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/CONTRIBUTING.md

@@ -0,0 +1,153 @@
+# The SLIME Hacker's Handbook
+
+## Lisp code file structure
+
+The Lisp code is organised into these files:
+
+* `swank-backend.lisp`: Definition of the interface to non-portable
+features.  Stand-alone.
+
+* `swank-<cmucl|...>.lisp`: Backend implementation for a specific
+Common Lisp system.  Uses swank-backend.lisp.
+
+* `swank.lisp`: The top-level server program, built from the other
+components.  Uses swank-backend.lisp as an interface to the actual
+backends.
+
+* `slime.el`: The Superior Lisp Inferior Mode for Emacs, i.e. the
+Emacs frontend that the user actually interacts with and that connects
+to the SWANK server to send expressions to, and retrieve information
+from the running Common Lisp system.
+
+* `contrib/*.lisp`: Lisp related code for add-ons to SLIME that are
+maintained by their respective authors. Consult contrib/README for
+more information.
+
+## Test Suite
+
+The Makefile includes a `check` target to run the ERT-based test
+suite. This can give a pretty good sanity-check for your changes
+
+Some backends do not pass the full test suite because of missing
+features. In these cases the test suite is still useful to ensure that
+changes don't introduce new errors. CMUCL historically passes the full
+test suite so it makes a good sanity check for fundamental changes
+(e.g. to the protocol).
+
+Running the test suite, adding new cases, and increasing the number of
+cases that backends support are all very good for karma.
+
+
+## Source code layout
+
+We use a special source file layout to take advantage of some fancy
+Emacs features: outline-mode and "narrowing".
+
+### Outline structure
+
+Our source files have a hierarchical structure using comments like
+these:
+
+```el
+;;;; Heading
+;;;;; Subheading
+... etc
+```
+
+We do this as a nice way to structure the program. We try to keep each
+(sub)section small enough to fit in your head: typically around 50-200
+lines of code each. Each section usually begins with a brief
+introduction, followed by its highest-level functions, followed by
+their subroutines. This is a pleasing shape for a source file to have.
+
+Of course the comments mean something to Emacs too. One handy usage is
+to bring up a hyperlinked "table of contents" for the source file
+using this command:
+
+```el
+(defun show-outline-structure ()
+  "Show the outline-mode structure of the current buffer."
+  (interactive)
+  (occur (concat "^" outline-regexp)))
+```
+
+Another is to use `outline-minor-mode` to fold away certain parts of
+the buffer. See the `Outline Mode` section of the Emacs manual for
+details about that.
+
+### Pagebreak characters (^L)
+
+We partition source files into chunks using pagebreak characters. Each
+chunk is a substantial piece of code that can be considered in
+isolation, that could perhaps be a separate source file if we were
+fanatical about small source files (rather than big ones!)
+
+The page breaks usually go in the same place as top-level outline-mode
+headings, but they don't have to. They're flexible.
+
+In the old days, when `slime.el` was less than 100 pages long, these
+page breaks were helpful when printing it out to read. Now they're
+useful for something else: narrowing.
+
+You can use `C-x n p` (`narrow-to-page`) to "zoom in" on a
+pagebreak-delimited section of the file as if it were a separate
+buffer in itself. You can then use `C-x n w` (`widen`) to "zoom out" and
+see the whole file again. This is tremendously helpful for focusing
+your attention on one part of the program as if it were its own file.
+
+(This file contains some page break characters. If you're reading in
+Emacs you can press `C-x n p` to narrow to this page, and then later
+`C-x n w` to make the whole buffer visible again.)
+
+
+## Coding style
+
+We like the fact that each function in SLIME will fit on a single
+screen (80x20), and would like to preserve this property! Beyond that
+we're not dogmatic :-)
+
+In early discussions we all made happy noises about the advice in
+Norvig and Pitman's
+[Tutorial on Good Lisp Programming Style](http://www.norvig.com/luv-slides.ps).
+
+For Emacs Lisp, we try to follow the _Tips and Conventions_ in
+Appendix D of the GNU Emacs Lisp Reference Manual (see Info file
+`elisp`, node `Tips`).
+
+We use Emacs conventions for docstrings: the first line should be a
+complete sentence to make the output of `apropos` look good.  We also
+use imperative verbs.
+
+Now that XEmacs support is gone, rewrites using packages in GNU
+Emacs's core get extra karma.
+
+Customization variables complicate testing and therefore we only add
+new ones after careful consideration.  Adding new customization
+variables is bad for karma.
+
+We generally neither use nor recommend eval-after-load.
+
+The biggest problem with SLIME's code base is feature creep.  Keep in
+mind that the Right Thing isn't always the Smart Thing.  If you can't
+find an elegant solution to a problem then you're probably solving the
+wrong problem.  It's often a good idea to simplify the problem and to
+ignore rarely needed cases.
+
+_Remember that to rewrite a program better is the sincerest form of
+code appreciation. When you can see a way to rewrite a part of SLIME
+better, please do so!_
+
+
+
+## Pull requests
+
+* Read [how to properly contribute to open source projects on Github][1].
+* Use a topic branch to easily amend a pull request later, if necessary.
+* Open a [pull request][2] that relates to *only* one subject with a
+  clear title and description in grammatically correct, complete
+  sentences.
+* Write [good commit messages][3].
+
+[1]: http://gun.io/blog/how-to-github-fork-branch-and-pull-request
+[2]: https://help.github.com/articles/using-pull-requests
+[3]: http://chris.beams.io/posts/git-commit/

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/Makefile

@@ -0,0 +1,113 @@
+### Makefile for SLIME
+#
+# This file is in the public domain.
+
+# Variables
+#
+EMACS=emacs
+LISP=sbcl
+
+LOAD_PATH=-L .
+
+ELFILES := slime.el slime-autoloads.el slime-tests.el $(wildcard lib/*.el)
+ELCFILES := $(ELFILES:.el=.elc)
+
+default: compile contrib-compile
+
+all: compile
+
+help:
+	@printf "\
+Main targets\n\
+all        -- see compile\n\
+compile    -- compile .el files\n\
+check      -- run tests in batch mode\n\
+clean      -- delete generated files\n\
+doc-help   -- print help about doc targets\n\
+help-vars  -- print info about variables\n\
+help       -- print this message\n"
+
+help-vars:
+	@printf "\
+Main make variables:\n\
+EMACS     -- program to start Emacs ($(EMACS))\n\
+LISP      -- program to start Lisp ($(LISP))\n\
+SELECTOR  -- selector for ERT tests ($(SELECTOR))\n"
+
+# Compilation
+#
+slime.elc: slime.el lib/hyperspec.elc
+
+%.elc: %.el
+	$(EMACS) -Q $(LOAD_PATH) --batch -f batch-byte-compile $<
+
+compile: $(ELCFILES)
+
+# Automated tests
+#
+SELECTOR=t
+
+check: compile
+	$(EMACS) -Q --batch $(LOAD_PATH)				\
+		--eval "(require 'slime-tests)"				\
+		--eval "(slime-setup)"					\
+		--eval "(setq inferior-lisp-program \"$(LISP)\")"	\
+		--eval '(slime-batch-test (quote $(SELECTOR)))'
+
+# run tests interactively
+#
+# FIXME: Not terribly useful until bugs in ert-run-tests-interactively
+# are fixed.
+test: compile
+	$(EMACS) -Q -nw $(LOAD_PATH)					\
+		--eval "(require 'slime-tests)"				\
+		--eval "(slime-setup)"					\
+		--eval "(setq inferior-lisp-program \"$(LISP)\")"	\
+		--eval '(slime-batch-test (quote $(SELECTOR)))'
+
+compile-swank:
+	echo '(load "swank-loader.lisp")' '(swank-loader:init :setup nil)' \
+	| $(LISP)
+
+run-swank:
+	{ echo \
+	'(load "swank-loader.lisp")' \
+	'(swank-loader:init)' \
+	'(swank:create-server)' \
+	&& cat; } \
+	| $(LISP)
+
+elpa-slime:
+	echo "Not implemented yet: elpa-slime target" && exit 255
+
+elpa: elpa-slime contrib-elpa
+
+# Cleanup
+#
+FASLREGEX = .*\.\(fasl\|ufasl\|sse2f\|lx32fsl\|abcl\|fas\|lib\|trace\)$$
+
+clean-fasls:
+	find . -regex '$(FASLREGEX)' -exec rm -v {} \;
+	[ ! -d ~/.slime/fasl ] || rm -rf ~/.slime/fasl
+
+clean: clean-fasls
+	find . -iname '*.elc' -exec rm {} \;
+
+
+# Contrib stuff. Should probably also go to contrib/
+#
+MAKECONTRIB=$(MAKE) -C contrib EMACS="$(EMACS)" LISP="$(LISP)"
+contrib-check-% check-%:
+	$(MAKECONTRIB) $(@:contrib-%=%)
+contrib-elpa:
+	$(MAKECONTRIB) elpa-all
+contrib-compile:
+	$(MAKECONTRIB) compile
+
+# Doc
+#
+doc-%:
+	$(MAKE) -C doc $(@:doc-%=%)
+doc: doc-help
+
+.PHONY: clean elpa compile check doc dist

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/NEWS

@@ -0,0 +1,609 @@
+* SLIME News                                -*- mode: outline; coding: utf-8 -*-
+* 2.24 (May 2019)
+*** Minor improvements.
+
+* 2.23 (December 2018)
+*** Improved compatiblity with different versions of Emacs, SBCL, Clasp, Allegro.
+*** Bug fixes
+
+* 2.22 (July 2018)
+*** Improved compatiblity with Emacs 26
+
+* 2.21 (June 2018)
+*** Improved compatiblity with Emacs 26
+*** Mezzano support
+
+* 2.20 (August 2017)
+** Core
+*** More secure handling of ~/.slime-secret
+** SBCL backend
+*** Compatiblity with the latest SBCL and older SBCL.
+** ECL backend
+*** Numerous enhancements
+
+* 2.19 (February 2017)
+** Core
+*** Function `create-server` now accepts optional `interface` argument.
+Swank will bind the PORT on this interface. By default, interface is 127.0.0.1.
+This argument can be used, for example, to bind swank on IPv6 interface "::1".
+** SBCL backend
+*** Now swank can be bound to IPv6 interface and can work on IPv6-only machines.
+*** Compatiblity with the latest SBCL
+
+* 2.18 (May 2016)
+*** Mostly bug fixes and compatibility with newer implementations
+
+* 2.17 (February 2016)
+** Contribs
+*** New contrib, slime-macrostep, for more advanced in-place macroexpansion.
+*** New contrib, slime-quicklisp.
+
+* 2.16 (January 2016)
+*** Auto-completion now supports package-local nicknames on SBCL and ABCL.
+*** Bug fixes and updates for newer implementations.
+
+* 2.15 (August 2015)
+** Core
+*** Completions are now displayed with `completion-at-point'.
+The new variable `slime-completion-at-point-functions' should now be
+used to customize completion.  The old variable
+`slime-complete-symbol-function' still works, but it is considered
+obsolete and will be removed eventually.
+
+** SBCL backend
+*** M-. can locate forms within PROGN/MACROLET/etc. Needs SBCL 1.2.15 
+
+* 2.14 (June 2015)
+** Core
+*** Rationals are displayed in the echo area as floats too
+*** Some of SLDB's faces now have MORE COLOR
+*** Clicking with mouse-1 within inspector does things
+As do mouse-6 and mouse-7. (Thanks to Attila Lendvai.)
+
+** slime-c-p-c (Compound Prefix Completion)
+*** Now takes a better guess at symbol case (issue #233)
+
+** slime-fancy
+*** slime-mdot-fu is now enabled by default
+
+** SBCL backend
+*** Now able to jump to ir1-translators, declaims and alien types
+*** Various updates supporting SBCL 1.2.12
+
+** ABCL backend
+*** Fixed inspection of frame-locals in the debugger
+(Thanks to Mark Evenson.)
+
+* 2.13 (March 2015)
+
+** Core
+*** slime-cycle-connections has been deprecated
+It has been replaced by slime-next-connection and
+slime-prev-connection. A shortcut for the latter has been added to
+slime-selector.
+
+** slime-mdot-fu
+The slime-mdot-fu contrib has been brought back to life. (Thanks to Charles
+Zhang. Issues #8, #231 and #232.)
+
+** slime-typeout-frame
+The slime-typeout-frame contrib has been restored. (Issue #221.)
+
+** SBCL backend
+*** Fixed xrefs coming from C-c C-c
+Issue #227.
+
+** CMUCL, SBCL and SCL backends
+*** Better support for custom readtables
+Functionality that depends on SWANK's source-path-parser, such as
+`slime-find-definition', now works properly in face of custom
+readtables by honoring SWANK:*READTABLE-ALIST*. (Thanks to Gábor
+Melis. PR #244.)
+
+** Kawa backend
+*** Updated for Kawa version 2.0
+
+* 2.12 (January 2015)
+
+** Core
+A couple of regressions introduced in version 2.10 were fixed.
+
+*** slime-compile-buffer (C-c C-k) no longer tries to save every buffer
+*** slime-autodoc-mode doesn't spam the minibuffer anymore
+
+** SWANK
+*** CREATE-SERVER provides interactive restarts when port is taken
+Thanks to Adlai Chandrasekhar. (PR #204.)
+
+** slime-fuzzy
+New variable *FUZZY-DUPLICATE-SYMBOL-FILTER* allows customization of
+how symbols accessible from multiple packages should be
+canonicalized. Defaults to :NEAREST-PACKAGE, a departure from the
+previous default behaviour which is still available using
+:HOME-PACKAGE. The new behaviour expands "ui:e-l" to
+"uiop:ensure-list" rather than "uiop/utility:ensure-list". Consult the
+manual for other options and other details.
+
+Thanks to Ivan Shvedunov. (PR #205.)
+
+* 2.11 (December 2014)
+
+** MELPA is now an officially supported installation method
+Various bugs involving installation and upgrading via package.el were
+fixed. See the README for more details. (Issues #125, #195, #208.)
+
+** Core
+*** Compilation via the xref buffer now works again
+
+** slime-repl / slime-presentations
+Only text to the left of the cursor should limit the scope of history
+navigation. Fixed a long-standing bug that violated this when
+slime-presentations was enabled. (Thanks to Ivan Shvedunov. PR #207.)
+
+** slime-package-fu
+Now handles strings as symbol designators, is mindful of trailing
+whitespace and properly handles an :export clause immediately
+following the package name. (Thanks to Leo Liu. PR #145.)
+
+** slime-indentation
+The edge case handling described in slime-cl-indent.el:958 have been
+has been restored.
+
+** Allegro CL backend
+Support for mlisp was restored. It had been broken by the previous
+release. (Reported by Alexandre Rademaker. Issue #209.)
+
+** New experimental SWANK backend for MLWorks
+
+** SWANK
+swank-listener-hooks was restored. (Thanks to Ivan Shvedunov. PR #210.)
+
+* 2.10.1 (October 2014)
+
+*** The SWANK-BACKEND nickname has been added to the SWANK/BACKEND package
+This should ease the migration of external projects that depend on the
+SWANK-BACKEND package. However, note that SWANK/BACKEND (as well as
+the other SWANK/* packages) are internal packages. Please refer to
+Conium <http://www.cliki.net/conium> for a project that purports to
+offer a stable API for debugger- and compiler-related tasks in Common
+Lisp.
+
+* 2.10 (October 2014)
+
+** Core
+*** The SWANK-BACKEND package has been renamed to SWANK/BACKEND
+Furthermore, implementations of the SWANK-BACKEND interface have
+individual packages such as SWANK/SBCL, SWANK/CCL, etc. Other packages
+such as SWANK-RPC, SWANK-GRAY have likewise had their hyphens turned
+into slashes.
+
+*** slime-compile-file is now aware of compilation-ask-about-save
+When set to nil, SLIME will save modified buffers without asking.
+compilation-save-buffers-predicate can be used to customize which
+buffers should be automatically saved.
+
+** slime-repl
+*** Clearing REPL output no longer deletes the prompt (issue #183)
+
+** slime-autodoc
+This contrib has been rewritten. Please report any regressions you may
+find.
+
+** ABCL backend
+*** Inspecting CLOS objects works properly again
+*** SLDB frame arguments have become inspectable
+
+** SBCL backend
+*** Source locations involving the #. reader macro
+The aforementioned mechanism was adapted to recent changes in the
+internals of the SBCL reader.
+
+*** Breakage involving recent versions of SBCL on Windows was fixed (issue #192)
+We no longer assume SB-SYS:ENABLE-INTERRUPT exists on Windows SBCL.
+
+** MKCL backend
+New backend for ManKai Common Lisp.
+
+** CMUCL backend
+*** Support for versions prior to 20c has been removed
+
+** MIT Scheme backend
+*** Updated and now requires MIT Scheme 9.2
+
+* 2.9 (August 2014)
+
+** Core
+*** Various display-related bugfixes
+
+** CMUCL
+*** M-. now works on condition classes
+
+* 2.8 (July 2014)
+
+** Core
+
+*** Inspector fixes and improvements for SBCL.
+
+** Contribs
+*** Kawa backend supports Kawa 1.14.
+
+* 2.7 (June 2014)
+
+** Core
+*** SWANK now tries harder to send double-floats to Emacs
+
+** Allegro CL Backend
+*** Added implementation for FUNCTION-NAME and FIND-SOURCE-LOCATION interfaces
+Notably, this means that pressing "." in the SLIME inspector now works
+on Allegro CL. (Thanks to Gábor Melis.)
+
+* 2.6 (May 2014)
+
+** Core
+
+*** *print-readably* bound to nil when displaying condition messages
+
+*** Issue #144: Removed nicknames and short package names
+The STD nickname for SWANK-TRACE-DIALOG was removed. MONITOR was
+renamed to SWANK-MONITOR and its nickname MON removed.
+
+*** Issues #135, #154: slime-to-lisp-filename used more pervasively
+Now used for the both the port-file and loader file when announced
+from Emacs to the lisp backend. Allows a user-written
+`slime-to-lisp-filename-function' that supports Cygwin lisps with
+non-Cygwin Emacsen or vice-versa. See #135 for an example of such a
+function.
+
+*** Issue #155: Stale SLDB buffers are now properly removed
+Indirect exits from an SLDB buffer that was not selected in a window
+would leave a stale buffer behind, leading to an inconsistent state
+and unexpected errors.
+
+** Contribs
+
+*** Issue #139: Restored "copy to REPL" for slime-presentations
+`slime-copy-presentation-at-point-to-repl' will copy a presentation to
+the REPL, place it at point, and _not_ set *, ** and ***. This
+behaviour restored after refactorings of "copy to REPL" behaviour of
+previous versions.
+
+*** Issue #140: Improvements in the "copy to REPL" behaviour
+With or without the slime-presentations contrib, M-RET will
+copy/return values to REPL from both Inspector and SLDB buffers,
+setting *, ** and *** . If the slime-presentations contrib is enabled,
+the returned part will be an interactive presentation. The protocol
+for copying down parts to REPL has been reworked to not assume a CL
+backend .
+
+*** Now supports more CLHS references: :type, :system-class, :ansi-cl
+
+*** Issue #133: Fixed links to the SBCL manual
+
+** Backend improvements
+
+*** SBCL
+
+**** `slime-set-default-directory' now calls chdir
+This propagates its effects to subprocesses.
+
+* 2.5 (April 2014)
+
+** Backend improvements
+
+*** Clozure CL
+
+**** `slime-set-default-directory' now calls chdir
+This propagates its effects to subprocesses.
+
+*** Allegro CL
+
+**** swank-compile-string no longer binds *default-pathname-defaults*
+This was inconsistent with the behaviour of other backends and caused
+strange issues with SYS:TEMPORARY-DIRECTORY.
+
+**** Improved source file recording
+Whenever possible interactive definition compilation is mapped to the
+actual source file rather than the buffer name to avoid breakage when
+the the buffer name changes or is closed.
+
+** SLIME Trace Dialog
+
+*** (Un)Tracing a definition automatically updates the trace status
+
+** slime-repl
+
+*** Inspecting * in REPL no longer inspects ** (issue #137)
+
+** slime-autodoc
+
+*** Multiline arglists in `slime-autodoc' no longer imply a newline (issue #7)
+
+** Core Bugfixes
+
+*** SWANK port file name defined in more portable fashion
+Bug reported by Mirko Vukovic on slime-devel.
+
+*** inferior-lisp-program can now hold paths with spaces (issue #116)
+
+* 2.4 (March 2014)
+
+** New contrib SLIME Trace Dialog included in `slime-fancy'
+Interactive interface to tracing functions and methods. See manual for
+details.
+
+** New contrib `slime-fancy-trace', included in `slime-fancy'
+If your implementation allows it, trace complex method signatures,
+labels, etc...
+
+** New options in `slime-cl-indent.el' used by the `slime-indentation' contrib
+New variables are `lisp-loop-body-forms-indentation' and
+`lisp-loop-body-forms-indentation'.
+
+** New command `sldb-copy-down-to-repl' bound to M-RET in debugger
+Copies the frame variable under point to the REPL, much as
+`slime-inspector-copy-down-to-repl' does.
+
+** New command `slime-delete-package'
+
+** UTF8 encoding
+SLIME now uses only UTF8 to encode strings on the wire.  Customization
+variables like `slime-net-coding-system' or `swank:*coding-system*' are
+now useless.
+
+** Setup recipe
+In preparation for a more decentralized approach to SLIME contribs,
+the setup recipe has been slightly changed, hopefully in a backwards
+compatible way. Calling `slime-setup' is no longer required. Instead,
+the `slime-contribs' variable can be customized with a list of
+contribs to be loaded when `M-x slime' is first executed. See section
+`8.1 Loading Contrib Packages' of the SLIME Manual for more details.
+
+** Bugfixes and stability improvements since the move to Github
+
+*** Issue #9: new REPL output respectes existing REPL results or presentations.
+
+*** Issue #17: TAB no longer freezes the REPL in "read-mode"
+
+*** Issue #42: compiles on Emacs 24
+
+*** Issue #43: `just-one-space' no longer breaks REPL
+
+*** Issue #34: "Error in timer" error when starting slime on emacs24
+
+*** Printing conditions is now a bit safer in the debugger (git:bafeb86)
+
+*** Fix undo behavior in the REPL (git:af354d7)
+Previously, undo would obliterate previous prompts.
+
+*** Fix REPL type-ahead behaviour when presentations active (git:38a1826)
+Input typed before your lisp responds is appended to the result when it arrives.
+
+*** Fix package and dir synch when no process buffer (git:dc88935)
+Sometimes process buffer has been killed, but connection is still active.
+
+*** M-p on any part of the REPL buffer no longer errors (git:dc88935)
+
+*** slime-presentations can be enabled in inspector (git:647c3c3, 2f57b34)
+Set `slime-inspector-insert-ispec-function' to
+`slime-presentation-inspector-insert-ispec' to use them.
+
+*** M-. on a presentation on the REPL now longer errors
+This happened when `slime-presentations' was enabled, either by itself
+or by `slime-fancy'.
+
+*** M-. on the first position of a *slime-apropos* buffer no longer fails.
+This happened with the `slime-fancy-inspector.el' contrib.
+
+*** RET on no part in *inspector* buffer no longer errors
+
+*** slime-repsentations properly recognized when at very beginning of buffer
+Fix by Attila Lendvai
+
+*** Avoid loading `swank-asdf.lisp' if there's a good chance it will break SWANK
+`swank-asdf.lisp' aborts the connection if it finds an old ASDF version.
+
+*** In ABCL, `slime-describe-function' now works for both macros and functions.
+
+** SLIME builds on Travis CI
+See https://travis-ci.org/slime/slime for the build status and history.
+
+** Testing framework refactored to use ERT
+`def-slime-test' creates regular ERT tests. `define-slime-ert-test' is
+a lighter convenience macro which automatically sets some tags for the
+new tests.
+
+** Top-level Makefile
+For hackers or users using the latest version, there is now a
+top-level Makefile. Use "make help" to learn about targets.
+
+** Moved to Github
+SLIME now lives in Github. The documentation and the README.md file
+were updated. HACKING was renamed to CONTRIBUTING.md and updated with
+Github specific instructions.
+
+** Bugfixes and stability improvements
+Since the last release and before move to Github, many bugfixes and
+other changes were commited, too many to list here. See Changelog for
+details.
+
+* 2.3 (October 2011)
+
+** REPL no longer loaded by default
+SLIME has a REPL which communicates exclusively over SLIME's socket.
+This REPL is no longer loaded by default.  The default REPL is now the
+one by the Lisp implementation in the *inferior-lisp* buffer.  The
+simplest way to enable the old REPL is:
+
+  (slime-setup '(slime-repl))
+
+** Precise source tracking in Clozure CL
+Recent versions of the CCL compiler support source-location tracking.
+This makes the sldb-show-source command much more useful and M-. works
+better too.
+
+** Environment variables for Lisp process
+slime-lisp-implementations can be used to specify a list of strings to
+augment the process environment of the Lisp process.  E.g.:
+
+    (sbcl-cvs
+     ("/home/me/sbcl-cvs/src/runtime/sbcl"
+      "--core" "/home/me/sbcl-cvs/output/sbcl.core")
+     :env ("SBCL_HOME=/home/me/sbcl-cvs/contrib/"))
+
+* 2.1
+
+** Removed Features
+Some of the more esoteric features, like presentations or fuzzy
+completion, are no longer enabled by default.  A new directory
+"contrib/" contains the code for these packages.  To use them, you
+must make some changes to your ~/.emacs.  For details see, section
+"Contributed Packages" in the manual.
+
+** Stepper
+Juho Snellman implemented stepping commands for SBCL.
+
+** Completions
+SLIME can now complete keywords and character names (like #\newline).
+
+* 2.0 (April 2006)
+
+** In-place macro expansion
+Marco Baringer wrote a new minor mode to incrementally expand macros.
+
+** Improved arglist display
+SLIME now recognizes `make-instance' calls and displays the correct
+arglist if the classname is present.  Similarly, for `defmethod' forms
+SLIME displays the arguments of the generic function.
+
+** Persistent REPL history
+SLIME now saves the command history from REPL buffers in a file and
+reloads it for newly created REPL buffers.
+
+** Scieneer Common Lisp
+Douglas Crosher added support for Scieneer Common Lisp.
+
+** SBCL
+Various improvements to make SLIME work well with current SBCL versions.
+
+** Corman Common Lisp
+Espen Wiborg added support for Corman Common Lisp.
+
+** Presentations
+A new feature which associates objects in Lisp with their textual
+represetation in Emacs.  The text is clickable and operations on the
+associated object can be invoked from a pop-up menu.
+
+** Security
+SLIME has now a simple authentication mechanism: if the file
+~/.slime-secret exists we verify that Emacs and Lisp can access it.
+Since both parties have access to the same file system, we assume that
+we can trust each other.
+
+* 1.2 (March 2005)
+
+** New inspector
+The lisp side now returns a specially formated list of "things" to
+format which are then passed to emacs and rendered in the inspector
+buffer. Things can be either text, recursivly inspectable values, or
+functions to call. The new inspector has much better support CLOS
+objects and methods.
+
+** Unicode
+It's now possible to send non-ascii characters to Emacs, if the
+communication channel is configured properly.  See the variable
+`slime-net-coding-system'.
+
+** Arglist lookup while debugging
+Previously, arglist lookup was disabled while debugging.  This
+restriction was removed. 
+
+** Extended tracing command
+It's now possible to trace individual a single methods or all methods
+of a generic function.  Also tracing can be restricted to situations
+in which the traced function is called from a specific function.
+
+** M-x slime-browse-classes
+A simple class browser was added.
+
+** FASL files
+The fasl files for different Lisp/OS/hardware combinations are now
+placed in different directories.
+
+** Many other small improvements and bugfixes
+
+* 1.0 (September 2004)
+
+** slime-interrupt
+The default key binding for slime-interrupt is now C-c C-b.
+
+** sldb-inspect-condition
+In SLDB 'C' is now bound to sldb-inspect-condition.
+
+** More Menus
+SLDB and the REPL have now pull-down menus.
+
+** Global debugger hook.
+A new configurable *global-debugger* to control whether
+swank-debugger-hook should be installed globally is available. True by
+default.
+
+** When you call sldb-eval-in-frame with a prefix argument, the result is 
+now inserted in the REPL buffer.
+
+** Compile function
+For Allegro M-. works now for functions compiled with C-c C-c.
+
+** slime-edit-definition
+Better support for Allegro: works now for different type of
+definitions not only. So M-. now works for e.g. classes in Allegro.
+
+** SBCL 0.8.13
+SBCL 0.8.12 is no longer supported.  Support for 0.8.12 was broken for
+for some time now.
+
+* 1.0 beta (August 2004)
+
+** autodoc global variables
+The slime-autodoc-mode will now automatically show the value of a
+global variable at point.
+
+** Customize group
+The customize group is expanded and better-organised.
+
+** slime-interactive-eval
+Interactive-eval commands now print their results to the REPL when
+given a prefix argument.
+
+** slime-conservative-indentation
+New Elisp variable. Non-nil means that we exclude def* and with-* from
+indentation-learning. The default is t.
+
+** (slime-setup)
+New function to streamline setup in ~/.emacs
+
+** Modeline package
+The package name in the modeline is now updated on an idle timer. The
+message should now be more meaningful when moving around in files
+containing multiple IN-PACKAGE forms.
+
+** XREF bugfix
+The XREF commands did not find symbols in the right package.
+
+** REPL prompt
+The package name in the REPL's prompt is now abbreviated to the last
+`.'-delimited token, e.g. MY.COMPANY.PACKAGE would be PACKAGE. This
+can be disabled by setting SWANK::*AUTO-ABBREVIATE-DOTTED-PACKAGES* to
+NIL.
+
+** CMUCL source cache
+The source cache is now populated on `first-change-hook'. This makes
+M-. work accurately in more file modification scenarios.
+
+** SBCL compiler errors
+Detect compiler errors and make some noise. Previously certain
+problems (e.g. reader-errors) could slip by quietly.
+
+* 1.0 alpha (June 2004)
+
+The first preview release of SLIME.
+

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/PROBLEMS

@@ -0,0 +1,94 @@
+Known problems with SLIME                                   -*- outline -*-
+
+* Common to all backends
+
+** Caution: network security
+
+The `M-x slime' command has Lisp listen on a TCP socket and wait for
+Emacs to connect, which typically takes on the order of one second. If
+someone else were to connect to this socket then they could use the
+SLIME protocol to control the Lisp process.
+
+The listen socket is bound on the loopback interface in all Lisps that
+support this. This way remote hosts are unable to connect.
+
+** READ-CHAR-NO-HANG is broken
+
+READ-CHAR-NO-HANG doesn't work properly for slime-input-streams.  Due
+to the way we request input from Emacs it's not possible to repeatedly
+poll for input.  To get any input you have to call READ-CHAR (or a
+function which calls READ-CHAR).
+
+* Backend-specific problems
+
+** CMUCL
+
+The default communication style :SIGIO is reportedly unreliable with
+certain libraries (like libSDL) and certain platforms (like Solaris on
+Sparc). It generally works very well on x86 so it remains the default.
+
+** SBCL
+
+The latest released version of SBCL at the time of packaging should
+work.  Older or newer SBCLs may or may not work.  Do not use
+multithreading with unpatched 2.4 Linux kernels.  There are also
+problems with kernel versions 2.6.5 - 2.6.10.
+
+The (v)iew-source command in the debugger can only locate exact source
+forms for code compiled at (debug 2) or higher. The default level is
+lower and SBCL itself is compiled at a lower setting. Thus only
+defun-granularity is available with default policies.
+
+** LispWorks
+
+On Windows, SLIME hangs when calling foreign functions or certain
+other functions.  The reason for this problem is unknown.
+
+We only support latin1 encoding.  (Unicode wouldn't be hard to add.)
+
+** Allegro CL
+
+Interrupting Allegro with C-c C-b can be slow.  This is caused by the
+a relatively large process-quantum: 2 seconds by default.  Allegro
+responds much faster if mp:*default-process-quantum* is set to 0.1.
+
+** CLISP
+
+We require version 2.49 or higher. We also require socket support, so
+you may have to start CLISP with "clisp -K full".
+
+Under Windows, interrupting (with C-c C-b) doesn't work.  Emacs sends
+a SIGINT signal, but the signal is either ignored or CLISP exits
+immediately.
+
+On Windows, CLISP may refuse to parse filenames like
+"C:\\DOCUME~1\\johndoe\\LOCALS~1\\Temp\\slime.1424" when we actually
+mean C:\Documents and Settings\johndoe\Local Settings\slime.1424.  As
+a workaround, you could set slime-to-lisp-filename-function to some
+function that returns a string that is accepted by CLISP.
+
+Function arguments and local variables aren't displayed properly in
+the backtrace.  Changes to CLISP's C code are needed to fix this
+problem.  Interpreted code is usually easer to debug.
+
+M-. (find-definition) only works if the fasl file is in the same
+directory as the source file.
+
+The arglist doesn't include the proper names only "fake symbols" like
+`arg1'.
+
+** Armed Bear Common Lisp
+
+The ABCL support is still new and experimental.
+
+** Corman Common Lisp
+
+We require version 2.51 or higher, with several patches (available at
+http://www.grumblesmurf.org/lisp/corman-patches).
+
+The only communication style currently supported is NIL.
+
+Interrupting (with C-c C-b) doesn't work.
+
+The tracing, stepping and XREF commands are not implemented along with
+some debugger functionality.

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/README.md

@@ -0,0 +1,78 @@
+[![Build Status](https://img.shields.io/travis/slime/slime/master.svg)](https://travis-ci.org/slime/slime) [![MELPA](http://melpa.org/packages/slime-badge.svg?)](http://melpa.org/#/slime) [![MELPA Stable](http://stable.melpa.org/packages/slime-badge.svg?)](http://stable.melpa.org/#/slime)
+
+Overview
+--------
+
+SLIME is the Superior Lisp Interaction Mode for Emacs.
+
+SLIME extends Emacs with support for interactive programming in Common
+Lisp. The features are centered around slime-mode, an Emacs minor-mode that
+complements the standard lisp-mode. While lisp-mode supports editing Lisp
+source files, slime-mode adds support for interacting with a running Common
+Lisp process for compilation, debugging, documentation lookup, and so on.
+
+For much more information, consult [the manual][1].
+
+
+Quick setup instructions
+------------------------
+
+  1. [Set up the MELPA repository][2], if you haven't already, and install
+     SLIME using `M-x package-install RET slime RET`.
+
+  2. Add the following lines to your `~/.emacs` file, filling in in
+     the appropriate filenames:
+
+     ```el
+     ;; Set your lisp system and, optionally, some contribs
+     (setq inferior-lisp-program "/opt/sbcl/bin/sbcl")
+     (setq slime-contribs '(slime-fancy))
+     ```
+
+  3. Use `M-x slime` to fire up and connect to an inferior Lisp. SLIME will
+     now automatically be available in your Lisp source buffers.
+
+If you'd like to contribute to SLIME, you will want to instead follow
+the manual's instructions on [how to install SLIME via Git][7].
+
+
+Contribs
+--------
+
+SLIME comes with additional contributed packages or "contribs".
+Contribs can be selected via the `slime-contribs` list.
+
+The most-often used contrib is `slime-fancy`, which primarily installs a
+popular set of other contributed packages. It includes a better REPL, and
+many more nice features.
+
+
+License
+-------
+
+SLIME is free software. All files, unless explicitly stated otherwise, are
+public domain.
+
+
+Contact
+-------
+
+If you have problems, first have a look at the list of
+[known issues and workarounds][6]. 
+
+Questions and comments are best directed to the mailing list at
+`slime-devel@common-lisp.net`, but you have to [subscribe][3] first. The
+mailing list archive is also available on [Gmane][4].
+
+See the [CONTRIBUTING.md][5] file for instructions on how to contribute.
+
+
+
+
+[1]: http://common-lisp.net/project/slime/doc/html/
+[2]: http://melpa.org/#/getting-started
+[3]: http://www.common-lisp.net/project/slime/#mailinglist
+[4]: http://news.gmane.org/gmane.lisp.slime.devel
+[5]: https://github.com/slime/slime/blob/master/CONTRIBUTING.md
+[6]: https://github.com/slime/slime/issues?labels=workaround&state=closed
+[7]: http://common-lisp.net/project/slime/doc/html/Installation.html#Installing-from-Git

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/Makefile

@@ -0,0 +1,92 @@
+### Makefile for contribs
+#
+# This file is in the public domain.
+
+EMACS=emacs
+LISP=sbcl
+
+LOAD_PATH=-L . -L ..
+CONTRIBS = $(patsubst slime-%.el,%,$(wildcard slime-*.el))
+CONTRIB_TESTS = $(patsubst test/slime-%-tests.el,%,$(wildcard test/slime-*.el))
+SLIME_VERSION=$(shell grep "Version:" ../slime.el | grep -E -o "[0-9.]+$$")
+
+ELFILES := $(shell find . -type f -iname "*.el")
+ELCFILES := $(patsubst %.el,%.elc,$(ELFILES))
+
+%.elc: %.el
+	$(EMACS) -Q $(LOAD_PATH) --batch -f batch-byte-compile $<
+
+compile: $(ELCFILES)
+	$(EMACS) -Q --batch $(LOAD_PATH) \
+	        --eval "(batch-byte-recompile-directory 0)" .
+
+# ELPA builds for contribs
+#
+$(CONTRIBS:%=elpa-%): CONTRIB=$(@:elpa-%=%)
+$(CONTRIBS:%=elpa-%): CONTRIB_EL=$(CONTRIB:%=slime-%.el)
+$(CONTRIBS:%=elpa-%): CONTRIB_CL=$(CONTRIB:%=swank-%.lisp)
+$(CONTRIBS:%=elpa-%): CONTRIB_VERSION=$(shell (                          \
+	                                  grep "Version:" $(CONTRIB_EL)  \
+	                                  || echo $(SLIME_VERSION)       \
+	                                ) | grep -E -o "[0-9.]+$$" )
+$(CONTRIBS:%=elpa-%): PACKAGE=$(CONTRIB:%=slime-%-$(CONTRIB_VERSION))
+$(CONTRIBS:%=elpa-%): PACKAGE_EL=$(CONTRIB:%=slime-%-pkg.el)
+$(CONTRIBS:%=elpa-%): ELPA_DIR=elpa/$(PACKAGE)
+$(CONTRIBS:%=elpa-%): compile
+	elpa_dir=$(ELPA_DIR)
+	mkdir -p $$elpa_dir;                                             \
+	emacs --batch $(CONTRIB_EL)                                      \
+	--eval "(require 'cl-lib)"                                       \
+	--eval "(search-forward \"define-slime-contrib\")"               \
+	--eval "(up-list -1)"                                            \
+	--eval "(pp                                                      \
+	        (pcase (read (point-marker))                             \
+	          (\`(define-slime-contrib ,name ,docstring . ,rest)     \
+	           \`(define-package ,name \"$(CONTRIB_VERSION)\"        \
+	        ,docstring                                               \
+	        ,(cons '(slime \"$(SLIME_VERSION)\")                     \
+	         (cl-loop for form in rest                               \
+	             when (eq :slime-dependencies (car form))            \
+	             append (cl-loop for contrib in (cdr form)           \
+	                             if (atom contrib)                   \
+	                             collect                             \
+	                               \`(,contrib \"$(SLIME_VERSION)\") \
+	                             else                                \
+	                             collect contrib))))))))"   >        \
+	$$elpa_dir/$(PACKAGE_EL);                                        \
+	cp $(CONTRIB_EL) $$elpa_dir;                                     \
+	[ -r $(CONTRIB_CL) ] && cp $(CONTRIB_CL) $$elpa_dir;             \
+	ls $$elpa_dir
+	cd elpa && tar cvf $(PACKAGE).tar $(PACKAGE)
+	rm -rf $(ELPA_DIR)
+
+elpa-all: $(CONTRIBS:%=elpa-%)
+
+$(CONTRIB_TESTS:%=check-%): CONTRIB_NAME=$(patsubst check-%,slime-%,$@)
+$(CONTRIB_TESTS:%=check-%): SELECTOR=(quote (tag contrib))
+$(CONTRIB_TESTS:%=check-%): compile
+	$(EMACS) -Q --batch $(LOAD_PATH) -L test			   \
+	        --eval "(require (quote slime))"			   \
+	        --eval "(slime-setup (quote ($(CONTRIB_NAME))))"	   \
+	        --eval "(require					   \
+                         (intern					   \
+			  (format \"%s-tests\" (quote $(CONTRIB_NAME)))))" \
+	        --eval '(setq inferior-lisp-program "$(LISP)")'		   \
+	        --eval "(slime-batch-test $(SELECTOR))"
+
+check-all: $(CONTRIB_TESTS:%=check-%)
+
+check-fancy: compile
+	$(EMACS) -Q --batch  $(LOAD_PATH) -L test			\
+	        --eval "(setq debug-on-error t)"			\
+	        --eval "(require (quote slime))"			\
+	        --eval "(slime-setup (quote (slime-fancy)))"		\
+	        --eval "(mapc (lambda (sym)				\
+	                         (require				\
+	                           (intern (format \"%s-tests\" sym))	\
+	                           nil t))				\
+	                      (slime-contrib-all-dependencies		\
+	                        (quote slime-fancy)))"			\
+	        --eval '(setq inferior-lisp-program "$(LISP)")'		\
+	        --eval '(slime-batch-test (quote (tag contrib)))'
+

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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.

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/bridge.el

@@ -0,0 +1,472 @@
+;;; -*-Emacs-Lisp-*-
+;;;%Header
+;;; Bridge process filter, V1.0
+;;; Copyright (C) 1991 Chris McConnell, ccm@cs.cmu.edu  
+;;;
+;;; Send mail to ilisp@cons.org if you have problems.
+;;;
+;;; Send mail to majordomo@cons.org if you want to be on the
+;;; ilisp mailing list.
+
+;;; This file is part of GNU Emacs.
+
+;;; GNU Emacs is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY.  No author or distributor
+;;; accepts responsibility to anyone for the consequences of using it
+;;; or for whether it serves any particular purpose or works at all,
+;;; unless he says so in writing.  Refer to the GNU Emacs General Public
+;;; License for full details.
+
+;;; Everyone is granted permission to copy, modify and redistribute
+;;; GNU Emacs, but only under the conditions described in the
+;;; GNU Emacs General Public License.   A copy of this license is
+;;; supposed to have been given to you along with GNU Emacs so you
+;;; can know your rights and responsibilities.  It should be in a
+;;; file named COPYING.  Among other things, the copyright notice
+;;; and this notice must be preserved on all copies.
+
+;;; Send any bugs or comments.  Thanks to Todd Kaufmann for rewriting
+;;; the process filter for continuous handlers.
+
+;;; USAGE: M-x install-bridge will add a process output filter to the
+;;; current buffer.  Any output that the process does between
+;;; bridge-start-regexp and bridge-end-regexp will be bundled up and
+;;; passed to the first handler on bridge-handlers that matches the
+;;; output using string-match.  If bridge-prompt-regexp shows up
+;;; before bridge-end-regexp, the bridge will be cancelled.  If no
+;;; handler matches the output, the first symbol in the output is
+;;; assumed to be a buffer name and the rest of the output will be
+;;; sent to that buffer's process.  This can be used to communicate
+;;; between processes or to set up two way interactions between Emacs
+;;; and an inferior process.
+
+;;; You can write handlers that process the output in special ways.
+;;; See bridge-send-handler for the default handler.  The command
+;;; hand-bridge is useful for testing.  Keep in mind that all
+;;; variables are buffer local.
+
+;;; YOUR .EMACS FILE:
+;;;
+;;; ;;; Set up load path to include bridge
+;;; (setq load-path (cons "/bridge-directory/" load-path))
+;;; (autoload 'install-bridge "bridge" "Install a process bridge." t)
+;;; (setq bridge-hook 
+;;;       '(lambda ()
+;;;         ;; Example options
+;;;         (setq bridge-source-insert nil) ;Don't insert in source buffer
+;;;         (setq bridge-destination-insert nil) ;Don't insert in dest buffer
+;;;         ;; Handle copy-it messages yourself
+;;;         (setq bridge-handlers
+;;;          '(("copy-it" . my-copy-handler)))))
+
+;;; EXAMPLE:
+;;; # This pipes stdin to the named buffer in a Unix shell
+;;; alias devgnu '(echo -n "\!* "; cat -; echo -n "")'
+;;;
+;;; ls | devgnu *scratch*
+
+(eval-when-compile
+  (require 'cl))
+
+;;;%Parameters
+(defvar bridge-hook nil
+  "Hook called when a bridge is installed by install-hook.")
+
+(defvar bridge-start-regexp ""
+  "*Regular expression to match the start of a process bridge in
+process output.  It should be followed by a buffer name, the data to
+be sent and a bridge-end-regexp.")
+
+(defvar bridge-end-regexp ""
+  "*Regular expression to match the end of a process bridge in process
+output.")
+
+(defvar bridge-prompt-regexp nil
+  "*Regular expression for detecting a prompt.  If there is a
+comint-prompt-regexp, it will be initialized to that.  A prompt before
+a bridge-end-regexp will stop the process bridge.")
+
+(defvar bridge-handlers nil
+  "Alist of (regexp . handler) for handling process output delimited
+by bridge-start-regexp and bridge-end-regexp.  The first entry on the
+list whose regexp matches the output will be called on the process and
+the delimited output.")
+
+(defvar bridge-source-insert t
+  "*T to insert bridge input in the source buffer minus delimiters.")
+
+(defvar bridge-destination-insert t
+  "*T for bridge-send-handler to insert bridge input into the
+destination buffer minus delimiters.")
+
+(defvar bridge-chunk-size 512
+  "*Long inputs send to comint processes are broken up into chunks of
+this size.  If your process is choking on big inputs, try lowering the
+value.")
+
+;;;%Internal variables
+(defvar bridge-old-filter nil
+  "Old filter for a bridged process buffer.")
+
+(defvar bridge-string nil 
+  "The current output in the process bridge.")
+
+(defvar bridge-in-progress nil
+  "The current handler function, if any, that bridge passes strings on to,
+or nil if none.")
+
+(defvar bridge-leftovers nil
+  "Because of chunking you might get an incomplete bridge signal - start but the end is in the next packet. Save the overhanging text here.")
+
+(defvar bridge-send-to-buffer nil
+  "The buffer that the default bridge-handler (bridge-send-handler) is
+currently sending to, or nil if it hasn't started yet.  Your handler
+function can use this variable also.")
+
+(defvar bridge-last-failure ()
+  "Last thing that broke the bridge handler.  First item is function call
+(eval'able); last item is error condition which resulted.  This is provided
+to help handler-writers in their debugging.")
+
+(defvar bridge-insert-function nil
+  "If non-nil use this instead of `bridge-insert'")
+
+;;;%Utilities
+(defun bridge-insert (output &optional _dummy)
+  "Insert process OUTPUT into the current buffer."
+  (if bridge-insert-function
+      (funcall bridge-insert-function output)
+    (if output
+      (let* ((buffer (current-buffer))
+	     (process (get-buffer-process buffer))
+	     (mark (process-mark process))
+	     (window (selected-window))
+	     (at-end nil))
+	(if (eq (window-buffer window) buffer)
+	    (setq at-end (= (point) mark))
+	    (setq window (get-buffer-window buffer)))
+	(save-excursion
+	  (goto-char mark)
+	  (insert output)
+	  (set-marker mark (point)))
+	(if window 
+	    (progn
+	      (if at-end (goto-char mark))
+	      (if (not (pos-visible-in-window-p (point) window))
+		  (let ((original (selected-window)))
+		    (save-excursion
+		      (select-window window)
+		      (recenter '(center))
+		      (select-window original))))))))))
+
+;;;
+;(defun bridge-send-string (process string)
+;  "Send PROCESS the contents of STRING as input.
+;This is equivalent to process-send-string, except that long input strings
+;are broken up into chunks of size comint-input-chunk-size. Processes
+;are given a chance to output between chunks. This can help prevent processes
+;from hanging when you send them long inputs on some OS's."
+;  (let* ((len (length string))
+;	 (i (min len bridge-chunk-size)))
+;    (process-send-string process (substring string 0 i))
+;    (while (< i len)
+;      (let ((next-i (+ i bridge-chunk-size)))
+;	(accept-process-output)
+;	(process-send-string process (substring string i (min len next-i)))
+;	(setq i next-i)))))
+
+;;;
+(defun bridge-call-handler (handler proc string)
+  "Funcall HANDLER on PROC, STRING carefully.  Error is caught if happens,
+and user is signaled.  State is put in bridge-last-failure.  Returns t if
+handler executed without error."
+  (let ((inhibit-quit nil)
+	(failed nil))
+    (condition-case err
+	(funcall handler proc string)
+      (error
+       (ding)
+       (setq failed t)
+       (message "bridge-handler \"%s\" failed %s (see bridge-last-failure)"
+		handler err)
+       (setq bridge-last-failure
+             `((funcall ',handler ',proc ,string)
+               "Caused: "
+               ,err))))
+    (not failed)))
+
+;;;%Handlers
+(defun bridge-send-handler (process input)
+  "Send PROCESS INPUT to the buffer name found at the start of the
+input.  The input after the buffer name is sent to the buffer's
+process if it has one.  If bridge-destination-insert is T, the input
+will be inserted into the buffer.  If it does not have a process, it
+will be inserted at the end of the buffer."
+  (if (null input)
+      (setq bridge-send-to-buffer nil)  ; end of bridge
+      (let (buffer-and-start buffer-name dest to)
+	;; if this is first time, get the buffer out of the first line
+	(cond ((not bridge-send-to-buffer)
+	       (setq buffer-and-start (read-from-string input)
+		     buffer-name (format "%s" (car (read-from-string input)))
+		     dest        (get-buffer buffer-name)
+		     to          (get-buffer-process dest)
+		     input (substring input (cdr buffer-and-start)))
+	       (setq bridge-send-to-buffer dest))
+	      (t
+	       (setq buffer-name bridge-send-to-buffer
+		     dest        (get-buffer buffer-name)
+		     to          (get-buffer-process dest)
+		     )))
+	(if dest
+	    (let ((buffer (current-buffer)))
+	      (if bridge-destination-insert
+		  (unwind-protect
+		       (progn
+			 (set-buffer dest)
+			 (if to 
+			     (bridge-insert process input)
+			     (goto-char (point-max))
+			     (insert input)))
+		    (set-buffer buffer)))
+	      (if to
+		  ;; (bridge-send-string to input)
+		  (process-send-string to input)
+		  ))
+	    (error "%s is not a buffer" buffer-name)))))
+
+;;;%Filter
+(defun bridge-filter (process output)
+  "Given PROCESS and some OUTPUT, check for the presence of
+bridge-start-regexp.  Everything prior to this will be passed to the
+normal filter function or inserted in the buffer if it is nil.  The
+output up to bridge-end-regexp will be sent to the first handler on
+bridge-handlers that matches the string.  If no handlers match, the
+input will be sent to bridge-send-handler.  If bridge-prompt-regexp is
+encountered before the bridge-end-regexp, the bridge will be cancelled."
+  (let ((inhibit-quit t)
+	(match-data (match-data))
+	(buffer (current-buffer))
+	(process-buffer (process-buffer process))
+	(case-fold-search t)
+	(start 0) (end 0)
+	function
+	b-start b-start-end b-end)
+    (set-buffer process-buffer)	;; access locals
+
+    ;; Handle bridge messages that straddle a packet by prepending
+    ;; them to this packet.
+
+    (when bridge-leftovers
+      (setq output (concat bridge-leftovers output))
+      (setq bridge-leftovers nil))
+
+    (setq function bridge-in-progress)
+
+    ;; How it works:
+    ;;
+    ;; start, end delimit the part of string we are interested in;
+    ;; initially both 0; after an iteration we move them to next string.
+
+    ;; b-start, b-end delimit part of string to bridge (possibly whole string);
+    ;; this will be string between corresponding regexps.
+
+    ;; There are two main cases when we come into loop:
+
+    ;;  bridge in progress
+    ;;0    setq b-start = start
+    ;;1    setq b-end (or end-pattern end)
+    ;;4    process string
+    ;;5    remove handler if end found
+     
+    ;;  no bridge in progress
+    ;;0    setq b-start if see start-pattern
+    ;;1    setq b-end if bstart to (or end-pattern end)
+    ;;2    send (substring start b-start)  to normal place
+    ;;3    find handler (in b-start, b-end) if not set
+    ;;4    process string
+    ;;5    remove handler if end found
+
+    ;; equivalent sections have the same numbers here;
+    ;; we fold them together in this code.
+
+    (block bridge-filter
+      (unwind-protect
+	  (while (< end (length output))
+
+	    ;;0    setq b-start if find
+	    (setq b-start
+		  (cond (bridge-in-progress
+			 (setq b-start-end start)
+			 start)
+			((string-match bridge-start-regexp output start)
+			 (setq b-start-end (match-end 0))
+			 (match-beginning 0))
+			(t nil)))
+	    ;;1    setq b-end
+	    (setq b-end
+		  (if b-start
+		      (let ((end-seen (string-match bridge-end-regexp
+						    output b-start-end)))
+			(if end-seen (setq end (match-end 0)))
+
+			end-seen)))
+
+	    ;; Detect and save partial bridge messages
+	    (when (and b-start b-start-end (not b-end))
+	      (setq bridge-leftovers (substring output b-start))
+	      )
+
+	    (if (and b-start (not b-end))
+	      (setq end b-start)
+	    (if (not b-end)
+		(setq end (length output))))
+
+	    ;;1.5 - if see prompt before end, remove current
+	    (if (and b-start b-end)
+		(let ((prompt (string-match bridge-prompt-regexp
+					    output b-start-end)))
+		  (if (and prompt (<= (match-end 0) b-end))
+		      (setq b-start nil	; b-start-end start
+			    b-end   start
+			    end     (match-end 0)
+			    bridge-in-progress nil
+			    ))))
+
+	    ;;2    send (substring start b-start) to old filter, if any
+	    (when (not (equal start (or b-start end))) ; don't bother on empty string
+	      (let ((pass-on (substring output start (or b-start end))))
+		(if bridge-old-filter
+		    (let ((old bridge-old-filter))
+		      (store-match-data match-data)
+		      (funcall old process pass-on)
+		      ;; if filter changed, re-install ourselves
+		      (let ((new (process-filter process)))
+			(if (not (eq new 'bridge-filter))
+			    (progn (setq bridge-old-filter new)
+				   (set-process-filter process 'bridge-filter)))))
+		  (set-buffer process-buffer)
+		  (bridge-insert pass-on))))
+
+	    (if (and b-start-end (not b-end)) 
+		(return-from bridge-filter t) ; when last bit has prematurely ending message, exit  early.
+	      (progn
+		;;3 find handler (in b-start, b-end) if none current
+		(if (and b-start (not bridge-in-progress))
+		    (let ((handlers bridge-handlers))
+		      (while (and handlers (not function))
+			(let* ((handler (car handlers))
+			       (m (string-match (car handler) output b-start-end)))
+			  (if (and m (< m b-end))
+			      (setq function (cdr handler))
+			    (setq handlers (cdr handlers)))))
+		      ;; Set default handler if none
+		      (if (null function)
+			  (setq function 'bridge-send-handler))
+		      (setq bridge-in-progress function)))
+		;;4    process strin
+		(if function
+		    (let ((ok t))
+		      (if (/=  b-start-end b-end)
+			  (let ((send (substring output b-start-end b-end)))
+			    ;; also, insert the stuff in buffer between
+			    ;; iff bridge-source-insert.
+			    (if bridge-source-insert (bridge-insert send))
+			    ;; call handler on string
+			    (setq ok (bridge-call-handler function process send))))
+		      ;;5    remove handler if end found
+		      ;; if function removed then tell it that's all
+		      (if (or (not ok) (/= b-end end)) ;; saw end before end-of-string
+			  (progn
+			    (bridge-call-handler function process nil)
+			    ;; have to remove function too for next time around
+			    (setq function nil
+				  bridge-in-progress nil)
+			    ))
+		      ))
+     
+		;; continue looping, in case there's more string
+		(setq  start end))
+	      ))
+	;; protected forms:  restore buffer, match-data
+	(set-buffer buffer)
+	(store-match-data match-data)
+	))))
+
+
+;;;%Interface
+(defun install-bridge ()
+  "Set up a process bridge in the current buffer."
+  (interactive)
+  (if (not (get-buffer-process (current-buffer)))
+      (error "%s does not have a process" (buffer-name (current-buffer)))
+      (make-local-variable 'bridge-start-regexp)
+      (make-local-variable 'bridge-end-regexp)
+      (make-local-variable 'bridge-prompt-regexp)
+      (make-local-variable 'bridge-handlers)
+      (make-local-variable 'bridge-source-insert)
+      (make-local-variable 'bridge-destination-insert)
+      (make-local-variable 'bridge-chunk-size)
+      (make-local-variable 'bridge-old-filter)
+      (make-local-variable 'bridge-string)
+      (make-local-variable 'bridge-in-progress)
+      (make-local-variable 'bridge-send-to-buffer)
+      (make-local-variable 'bridge-leftovers)
+      (setq bridge-string nil bridge-in-progress nil
+	    bridge-send-to-buffer nil)
+      (if (boundp 'comint-prompt-regexp)
+	  (setq bridge-prompt-regexp comint-prompt-regexp))
+      (let ((process (get-buffer-process (current-buffer))))
+	(if process
+	    (if (not (eq (process-filter process) 'bridge-filter))
+		(progn
+		  (setq bridge-old-filter (process-filter process))
+		  (set-process-filter process 'bridge-filter)))
+	    (error "%s does not have a process" 
+		   (buffer-name (current-buffer)))))
+      (run-hooks 'bridge-hook)
+      (message "Process bridge is installed")))
+	      
+;;;
+(defun reset-bridge ()
+  "Must be called from the process's buffer.  Removes any active bridge."
+  (interactive)
+  ;; for when things get wedged
+  (if bridge-in-progress
+      (unwind-protect
+	   (funcall bridge-in-progress (get-buffer-process
+					(current-buffer))
+		    nil)
+	(setq bridge-in-progress nil))
+      (message "No bridge in progress.")))
+
+;;;
+(defun remove-bridge ()
+  "Remove bridge from the current buffer."
+  (interactive)
+  (let ((process (get-buffer-process (current-buffer))))
+    (if (or (not process) (not (eq (process-filter process) 'bridge-filter)))
+	(error "%s has no bridge" (buffer-name (current-buffer)))
+	;; remove any bridge-in-progress
+	(reset-bridge)
+	(set-process-filter process bridge-old-filter)
+	(funcall bridge-old-filter process bridge-string)
+	(message "Process bridge is removed."))))
+
+;;;% Utility for testing
+(defun hand-bridge (start end)
+  "With point at bridge-start, sends bridge-start + string +
+bridge-end to bridge-filter.  With prefix, use current region to send."
+  (interactive "r")
+  (let ((p0 (if current-prefix-arg (min start end)
+		(if (looking-at bridge-start-regexp) (point)
+		    (error "Not looking at bridge-start-regexp"))))
+	(p1 (if current-prefix-arg (max start end)
+		(if (re-search-forward bridge-end-regexp nil t)
+		    (point) (error "Didn't see bridge-end-regexp")))))
+    
+    (bridge-filter (get-buffer-process (current-buffer))
+		   (buffer-substring-no-properties p0 p1))
+    ))
+
+(provide 'bridge)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/inferior-slime.el

@@ -0,0 +1,133 @@
+;;; inferior-slime.el --- Minor mode with Slime keys for comint buffers
+;;
+;; Author: Luke Gorrie  <luke@synap.se>
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add something like this to your .emacs: 
+;;
+;;   (add-to-list 'load-path "<directory-of-this-file>")
+;;   (add-hook 'slime-load-hook (lambda () (require 'inferior-slime)))
+;;   (add-hook 'inferior-lisp-mode-hook (lambda () (inferior-slime-mode 1)))
+(require 'slime)
+(require 'cl-lib)
+
+(define-minor-mode inferior-slime-mode
+  "\\<slime-mode-map>\
+Inferior SLIME mode: The Inferior Superior Lisp Mode for Emacs.
+
+This mode is intended for use with `inferior-lisp-mode'. It provides a
+subset of the bindings from `slime-mode'.
+
+\\{inferior-slime-mode-map}"
+  :keymap
+  ;; Fake binding to coax `define-minor-mode' to create the keymap
+  '((" " 'undefined))
+
+  (slime-setup-completion)
+  (setq-local tab-always-indent 'complete))
+
+(defun inferior-slime-return ()
+  "Handle the return key in the inferior-lisp buffer.
+The current input should only be sent if a whole expression has been
+entered, i.e. the parenthesis are matched.
+
+A prefix argument disables this behaviour."
+  (interactive)
+  (if (or current-prefix-arg (inferior-slime-input-complete-p))
+      (comint-send-input)
+    (insert "\n")
+    (inferior-slime-indent-line)))
+
+(defun inferior-slime-indent-line ()
+  "Indent the current line, ignoring everything before the prompt."
+  (interactive)
+  (save-restriction
+    (let ((indent-start
+           (save-excursion
+             (goto-char (process-mark (get-buffer-process (current-buffer))))
+             (let ((inhibit-field-text-motion t))
+               (beginning-of-line 1))
+             (point))))
+      (narrow-to-region indent-start (point-max)))
+    (lisp-indent-line)))
+
+(defun inferior-slime-input-complete-p ()
+  "Return true if the input is complete in the inferior lisp buffer."
+  (slime-input-complete-p (process-mark (get-buffer-process (current-buffer)))
+                          (point-max)))
+
+(defun inferior-slime-closing-return ()
+  "Send the current expression to Lisp after closing any open lists."
+  (interactive)
+  (goto-char (point-max))
+  (save-restriction
+    (narrow-to-region (process-mark (get-buffer-process (current-buffer)))
+                      (point-max))
+    (while (ignore-errors (save-excursion (backward-up-list 1) t))
+      (insert ")")))
+  (comint-send-input))
+
+(defun inferior-slime-change-directory (directory)
+  "Set default-directory in the *inferior-lisp* buffer to DIRECTORY."
+  (let* ((proc (slime-process))
+	 (buffer (and proc (process-buffer proc))))
+    (when buffer 
+      (with-current-buffer buffer
+	(cd-absolute directory)))))
+
+(defun inferior-slime-init-keymap ()
+  (let ((map inferior-slime-mode-map))
+    (set-keymap-parent map slime-parent-map)
+    (slime-define-keys map
+      ([return]			'inferior-slime-return)
+      ([(control return)]	'inferior-slime-closing-return)
+      ([(meta control ?m)]	'inferior-slime-closing-return)
+      ;;("\t"			'slime-indent-and-complete-symbol)
+      (" "			'slime-space))))
+
+(inferior-slime-init-keymap)
+
+(defun inferior-slime-hook-function ()
+  (inferior-slime-mode 1))
+
+(defun inferior-slime-switch-to-repl-buffer ()
+  (switch-to-buffer (process-buffer (slime-inferior-process))))
+
+(defun inferior-slime-show-transcript (string)
+  (remove-hook 'comint-output-filter-functions
+	       'inferior-slime-show-transcript t)
+  (with-current-buffer (process-buffer (slime-inferior-process))
+    (let ((window (display-buffer (current-buffer) t)))
+      (set-window-point window (point-max)))))
+
+(defun inferior-slime-start-transcript ()
+  (let ((proc (slime-inferior-process)))
+    (when proc
+      (with-current-buffer (process-buffer proc)
+	(add-hook 'comint-output-filter-functions 
+		  'inferior-slime-show-transcript
+		  nil t)))))
+
+(defun inferior-slime-stop-transcript ()
+  (let ((proc (slime-inferior-process)))
+    (when proc
+      (with-current-buffer (process-buffer (slime-inferior-process))
+	(run-with-timer 0.2 nil 
+			(lambda (buffer) 
+			  (with-current-buffer buffer
+			    (remove-hook 'comint-output-filter-functions
+					 'inferior-slime-show-transcript t)))
+			(current-buffer))))))
+
+(defun inferior-slime-init ()
+  (add-hook 'slime-inferior-process-start-hook 'inferior-slime-hook-function)
+  (add-hook 'slime-change-directory-hooks 'inferior-slime-change-directory)
+  (add-hook 'slime-transcript-start-hook 'inferior-slime-start-transcript)
+  (add-hook 'slime-transcript-stop-hook 'inferior-slime-stop-transcript)
+  (def-slime-selector-method ?r
+    "SLIME Read-Eval-Print-Loop."
+    (process-buffer (slime-inferior-process))))
+
+(provide 'inferior-slime)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-asdf.el

@@ -0,0 +1,313 @@
+(require 'slime)
+(require 'cl-lib)
+(require 'grep)
+
+(define-slime-contrib slime-asdf
+  "ASDF support."
+  (:authors "Daniel Barlow       <dan@telent.net>"
+            "Marco Baringer      <mb@bese.it>"
+            "Edi Weitz           <edi@agharta.de>"
+            "Stas Boukarev       <stassats@gmail.com>"
+            "Tobias C Rittweiler <tcr@freebits.de>")
+  (:license "GPL")
+  (:slime-dependencies slime-repl)
+  (:swank-dependencies swank-asdf)
+  (:on-load
+   (add-to-list 'slime-edit-uses-xrefs :depends-on t)
+   (define-key slime-who-map [?d] 'slime-who-depends-on)))
+
+;;; NOTE: `system-name' is a predefined variable in Emacs.  Try to
+;;; avoid it as local variable name.
+
+;;; Utilities
+
+(defgroup slime-asdf nil
+  "ASDF support for Slime."
+  :prefix "slime-asdf-"
+  :group 'slime)
+
+(defvar slime-system-history nil
+  "History list for ASDF system names.")
+
+(defun slime-read-system-name (&optional prompt 
+                                         default-value
+                                         determine-default-accurately)
+  "Read a system name from the minibuffer, prompting with PROMPT.
+If no `default-value' is given, one is tried to be determined: if
+`determine-default-accurately' is true, by an RPC request which
+grovels through all defined systems; if it's not true, by looking
+in the directory of the current buffer."
+  (let* ((completion-ignore-case nil)
+         (prompt (or prompt "System"))
+         (system-names (slime-eval `(swank:list-asdf-systems)))
+         (default-value
+           (or default-value 
+               (if determine-default-accurately
+                   (slime-determine-asdf-system (buffer-file-name)
+                                                (slime-current-package))
+                   (slime-find-asd-file (or default-directory
+                                            (buffer-file-name))
+                                        system-names))))
+         (prompt (concat prompt (if default-value
+                                    (format " (default `%s'): " default-value)
+                                    ": "))))
+    (completing-read prompt (slime-bogus-completion-alist system-names)
+                     nil nil nil
+                     'slime-system-history default-value)))
+
+
+
+(defun slime-find-asd-file (directory system-names)
+  "Tries to find an ASDF system definition file in the
+`directory' and returns it if it's in `system-names'."
+  (let ((asd-files
+         (directory-files (file-name-directory directory) nil "\.asd$")))
+    (cl-loop for system in asd-files
+             for candidate = (file-name-sans-extension system)
+             when (cl-find candidate system-names :test #'string-equal)
+             do (cl-return candidate))))
+
+(defun slime-determine-asdf-system (filename buffer-package)
+  "Try to determine the asdf system that `filename' belongs to."
+  (slime-eval
+   `(swank:asdf-determine-system ,(and filename
+                                       (slime-to-lisp-filename filename))
+                                 ,buffer-package)))
+
+(defun slime-who-depends-on-rpc (system)
+  (slime-eval `(swank:who-depends-on ,system)))
+
+(defcustom slime-asdf-collect-notes t
+  "Collect and display notes produced by the compiler.
+
+See also `slime-highlight-compiler-notes' and
+`slime-compilation-finished-hook'."
+  :group 'slime-asdf)
+
+(defun slime-asdf-operation-finished-function (system)
+  (if slime-asdf-collect-notes
+      #'slime-compilation-finished
+      (slime-curry (lambda (system result)
+                     (let (slime-highlight-compiler-notes
+                           slime-compilation-finished-hook)
+                       (slime-compilation-finished result)))
+                   system)))
+
+(defun slime-oos (system operation &rest keyword-args)
+  "Operate On System."
+  (slime-save-some-lisp-buffers)
+  (slime-display-output-buffer)
+  (message "Performing ASDF %S%s on system %S"
+           operation (if keyword-args (format " %S" keyword-args) "")
+           system)
+  (slime-repl-shortcut-eval-async
+   `(swank:operate-on-system-for-emacs ,system ',operation ,@keyword-args)
+   (slime-asdf-operation-finished-function system)))
+
+
+;;; Interactive functions
+
+(defun slime-load-system (&optional system)
+  "Compile and load an ASDF system.  
+
+Default system name is taken from first file matching *.asd in current
+buffer's working directory"
+  (interactive (list (slime-read-system-name)))
+  (slime-oos system 'load-op))
+
+(defun slime-open-system (name &optional load interactive)
+  "Open all files in an ASDF system."
+  (interactive (list (slime-read-system-name) nil t))
+  (when (or load
+            (and interactive
+                 (not (slime-eval `(swank:asdf-system-loaded-p ,name)))
+                 (y-or-n-p "Load it? ")))
+    (slime-load-system name))
+  (slime-eval-async
+   `(swank:asdf-system-files ,name)
+   (lambda (files)
+     (when files
+       (let ((files (mapcar 'slime-from-lisp-filename
+                            (nreverse files))))
+         (find-file-other-window (car files))
+         (mapc 'find-file (cdr files)))))))
+
+(defun slime-browse-system (name)
+  "Browse files in an ASDF system using Dired."
+  (interactive (list (slime-read-system-name)))
+  (slime-eval-async `(swank:asdf-system-directory ,name)
+   (lambda (directory)
+     (when directory
+       (dired (slime-from-lisp-filename directory))))))
+
+(if (fboundp 'rgrep)
+    (defun slime-rgrep-system (sys-name regexp)
+      "Run `rgrep' on the base directory of an ASDF system."
+      (interactive (progn (grep-compute-defaults)
+                          (list (slime-read-system-name nil nil t)
+                                (grep-read-regexp))))
+      (rgrep regexp "*.lisp"
+             (slime-from-lisp-filename
+              (slime-eval `(swank:asdf-system-directory ,sys-name)))))
+    (defun slime-rgrep-system ()
+      (interactive)
+      (error "This command is only supported on GNU Emacs >21.x.")))
+
+(if (boundp 'multi-isearch-next-buffer-function)
+    (defun slime-isearch-system (sys-name)
+      "Run `isearch-forward' on the files of an ASDF system."
+      (interactive (list (slime-read-system-name nil nil t)))
+      (let* ((files (mapcar 'slime-from-lisp-filename
+                            (slime-eval `(swank:asdf-system-files ,sys-name))))
+             (multi-isearch-next-buffer-function
+              (lexical-let* 
+                  ((buffers-forward  (mapcar #'find-file-noselect files))
+                   (buffers-backward (reverse buffers-forward)))
+                #'(lambda (current-buffer wrap)
+                    ;; Contrarily to the docstring of
+                    ;; `multi-isearch-next-buffer-function', the first
+                    ;; arg is not necessarily a buffer. Report sent
+                    ;; upstream. (2009-11-17)
+                    (setq current-buffer (or current-buffer (current-buffer)))
+                    (let* ((buffers (if isearch-forward
+                                        buffers-forward
+                                        buffers-backward)))
+                      (if wrap
+                          (car buffers)
+                          (second (memq current-buffer buffers))))))))
+        (isearch-forward)))
+    (defun slime-isearch-system ()
+      (interactive)
+      (error "This command is only supported on GNU Emacs >23.1.x.")))
+
+(defun slime-read-query-replace-args (format-string &rest format-args)
+  (let* ((minibuffer-setup-hook (slime-minibuffer-setup-hook))
+         (minibuffer-local-map slime-minibuffer-map)
+         (common (query-replace-read-args (apply #'format format-string
+                                                 format-args)
+                                          t t)))
+    (list (nth 0 common) (nth 1 common) (nth 2 common))))
+
+(defun slime-query-replace-system (name from to &optional delimited)
+  "Run `query-replace' on an ASDF system."
+  (interactive (let ((system (slime-read-system-name nil nil t)))
+                 (cons system (slime-read-query-replace-args
+                               "Query replace throughout `%s'" system))))
+  (condition-case c
+      ;; `tags-query-replace' actually uses `query-replace-regexp'
+      ;; internally.
+      (tags-query-replace (regexp-quote from) to delimited
+                          '(mapcar 'slime-from-lisp-filename
+                            (slime-eval `(swank:asdf-system-files ,name))))
+    (error
+     ;; Kludge: `tags-query-replace' does not actually return but
+     ;; signals an unnamed error with the below error
+     ;; message. (<=23.1.2, at least.)
+     (unless (string-equal (error-message-string c) "All files processed")
+       (signal (car c) (cdr c)))        ; resignal
+     t)))
+
+(defun slime-query-replace-system-and-dependents
+    (name from to &optional delimited)
+  "Run `query-replace' on an ASDF system and all the systems
+depending on it."
+  (interactive (let ((system (slime-read-system-name nil nil t)))
+                 (cons system (slime-read-query-replace-args
+                               "Query replace throughout `%s'+dependencies"
+                               system))))
+  (slime-query-replace-system name from to delimited)
+  (dolist (dep (slime-who-depends-on-rpc name))
+    (when (y-or-n-p (format "Descend into system `%s'? " dep))
+      (slime-query-replace-system dep from to delimited))))
+
+(defun slime-delete-system-fasls (name)
+  "Delete FASLs produced by compiling a system."
+  (interactive (list (slime-read-system-name)))
+  (slime-repl-shortcut-eval-async
+   `(swank:delete-system-fasls ,name)
+   'message))
+
+(defun slime-reload-system (system)
+  "Reload an ASDF system without reloading its dependencies."
+  (interactive (list (slime-read-system-name)))
+  (slime-save-some-lisp-buffers)
+  (slime-display-output-buffer)
+  (message "Performing ASDF LOAD-OP on system %S" system)
+  (slime-repl-shortcut-eval-async
+   `(swank:reload-system ,system)
+   (slime-asdf-operation-finished-function system)))
+
+(defun slime-who-depends-on (system-name)
+  (interactive (list (slime-read-system-name)))
+  (slime-xref :depends-on system-name))
+
+(defun slime-save-system (system)
+  "Save files belonging to an ASDF system."
+  (interactive (list (slime-read-system-name)))
+  (slime-eval-async
+      `(swank:asdf-system-files ,system)
+    (lambda (files)
+      (dolist (file files)
+        (let ((buffer (get-file-buffer (slime-from-lisp-filename file))))
+          (when buffer
+            (with-current-buffer buffer
+              (save-buffer buffer)))))
+      (message "Done."))))
+
+
+;;; REPL shortcuts
+
+(defslime-repl-shortcut slime-repl-load/force-system ("force-load-system")
+  (:handler (lambda ()
+              (interactive)
+              (slime-oos (slime-read-system-name) 'load-op :force t)))
+  (:one-liner "Recompile and load an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-load-system ("load-system")
+  (:handler (lambda ()
+              (interactive)
+              (slime-oos (slime-read-system-name) 'load-op)))
+  (:one-liner "Compile (as needed) and load an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-test/force-system ("force-test-system")
+  (:handler (lambda ()
+              (interactive)
+              (slime-oos (slime-read-system-name) 'test-op :force t)))
+  (:one-liner "Recompile and test an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-test-system ("test-system")
+  (:handler (lambda ()
+              (interactive)
+              (slime-oos (slime-read-system-name) 'test-op)))
+  (:one-liner "Compile (as needed) and test an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-compile-system ("compile-system")
+  (:handler (lambda ()
+              (interactive)
+              (slime-oos (slime-read-system-name) 'compile-op)))
+  (:one-liner "Compile (but not load) an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-compile/force-system 
+  ("force-compile-system")  
+  (:handler (lambda ()
+              (interactive)
+              (slime-oos (slime-read-system-name) 'compile-op :force t)))
+  (:one-liner "Recompile (but not completely load) an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-open-system ("open-system")
+  (:handler 'slime-open-system)
+  (:one-liner "Open all files in an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-browse-system ("browse-system")
+  (:handler 'slime-browse-system)
+  (:one-liner "Browse files in an ASDF system using Dired."))
+
+(defslime-repl-shortcut slime-repl-delete-system-fasls ("delete-system-fasls")
+  (:handler 'slime-delete-system-fasls)
+  (:one-liner "Delete FASLs of an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-reload-system ("reload-system")
+  (:handler 'slime-reload-system)
+  (:one-liner "Recompile and load an ASDF system."))
+
+(provide 'slime-asdf)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-autodoc.el

@@ -0,0 +1,216 @@
+(require 'slime)
+(require 'eldoc)
+(require 'cl-lib)
+(require 'slime-parse)
+
+(define-slime-contrib slime-autodoc
+  "Show fancy arglist in echo area."
+  (:license "GPL")
+  (:authors "Luke Gorrie  <luke@bluetail.com>"
+            "Lawrence Mitchell  <wence@gmx.li>"
+            "Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>"
+            "Tobias C. Rittweiler  <tcr@freebits.de>")
+  (:slime-dependencies slime-parse)
+  (:swank-dependencies swank-arglists)
+  (:on-load (slime-autodoc--enable))
+  (:on-unload (slime-autodoc--disable)))
+
+(defcustom slime-autodoc-accuracy-depth 10
+  "Number of paren levels that autodoc takes into account for
+  context-sensitive arglist display (local functions. etc)"
+  :type 'integer
+  :group 'slime-ui)
+
+;;;###autoload
+(defcustom slime-autodoc-mode-string (purecopy " adoc")
+  "String to display in mode line when Autodoc Mode is enabled; nil for none."
+  :type '(choice string (const :tag "None" nil))
+  :group 'slime-ui)
+
+
+
+(defun slime-arglist (name)
+  "Show the argument list for NAME."
+  (interactive (list (slime-read-symbol-name "Arglist of: " t)))
+  (let ((arglist (slime-retrieve-arglist name)))
+    (if (eq arglist :not-available)
+        (error "Arglist not available")
+        (message "%s" (slime-autodoc--fontify arglist)))))
+
+;; used also in slime-c-p-c.el.
+(defun slime-retrieve-arglist (name)
+  (let ((name (cl-etypecase name
+		(string name)
+		(symbol (symbol-name name)))))
+    (car (slime-eval `(swank:autodoc '(,name ,slime-cursor-marker))))))
+
+(defun slime-autodoc-manually ()
+  "Like autodoc informtion forcing multiline display."
+  (interactive)
+  (let ((doc (slime-autodoc t)))
+    (cond (doc (eldoc-message doc))
+	  (t (eldoc-message nil)))))
+
+;; Must call eldoc-add-command otherwise (eldoc-display-message-p)
+;; returns nil and eldoc clears the echo area instead.
+(eldoc-add-command 'slime-autodoc-manually)
+
+(defun slime-autodoc-space (n)
+  "Like `slime-space' but nicer."
+  (interactive "p")
+  (self-insert-command n)
+  (let ((doc (slime-autodoc)))
+    (when doc
+      (eldoc-message doc))))
+
+(eldoc-add-command 'slime-autodoc-space)
+
+
+;;;; Autodoc cache
+
+(defvar slime-autodoc--cache-last-context nil)
+(defvar slime-autodoc--cache-last-autodoc nil)
+
+(defun slime-autodoc--cache-get (context)
+  "Return the cached autodoc documentation for `context', or nil."
+  (and (equal context slime-autodoc--cache-last-context)
+       slime-autodoc--cache-last-autodoc))
+
+(defun slime-autodoc--cache-put (context autodoc)
+  "Update the autodoc cache for CONTEXT with AUTODOC."
+  (setq slime-autodoc--cache-last-context context)
+  (setq slime-autodoc--cache-last-autodoc autodoc))
+
+
+;;;; Formatting autodoc
+
+(defsubst slime-autodoc--canonicalize-whitespace (string)
+  (replace-regexp-in-string "[ \n\t]+" " "  string))
+
+(defun slime-autodoc--format (doc multilinep)
+  (let ((doc (slime-autodoc--fontify doc)))
+    (cond (multilinep doc)
+	  (t (slime-oneliner (slime-autodoc--canonicalize-whitespace doc))))))
+
+(defun slime-autodoc--fontify (string)
+  "Fontify STRING as `font-lock-mode' does in Lisp mode."
+  (with-current-buffer (get-buffer-create (slime-buffer-name :fontify 'hidden))
+    (erase-buffer)
+    (unless (eq major-mode 'lisp-mode)
+      ;; Just calling (lisp-mode) will turn slime-mode on in that buffer,
+      ;; which may interfere with this function
+      (setq major-mode 'lisp-mode)
+      (lisp-mode-variables t))
+    (insert string)
+    (let ((font-lock-verbose nil))
+      (font-lock-fontify-buffer))
+    (goto-char (point-min))
+    (when (re-search-forward "===> \\(\\(.\\|\n\\)*\\) <===" nil t)
+      (let ((highlight (match-string 1)))
+        ;; Can't use (replace-match highlight) here -- broken in Emacs 21
+        (delete-region (match-beginning 0) (match-end 0))
+	(slime-insert-propertized '(face eldoc-highlight-function-argument) highlight)))
+    (buffer-substring (point-min) (point-max))))
+
+(define-obsolete-function-alias 'slime-fontify-string
+  'slime-autodoc--fontify
+  "SLIME 2.10")
+
+
+;;;; Autodocs (automatic context-sensitive help)
+
+(defun slime-autodoc (&optional force-multiline)
+  "Returns the cached arglist information as string, or nil.
+If it's not in the cache, the cache will be updated asynchronously."
+  (save-excursion
+    (save-match-data
+      (let ((context (slime-autodoc--parse-context)))
+	(when context
+	  (let* ((cached (slime-autodoc--cache-get context))
+		 (multilinep (or force-multiline
+				 eldoc-echo-area-use-multiline-p)))
+	    (cond (cached (slime-autodoc--format cached multilinep))
+		  (t
+		   (when (slime-background-activities-enabled-p)
+		     (slime-autodoc--async context multilinep))
+		   nil))))))))
+
+;; Return the context around point that can be passed to
+;; swank:autodoc.  nil is returned if nothing reasonable could be
+;; found.
+(defun slime-autodoc--parse-context ()
+  (and (slime-autodoc--parsing-safe-p)
+       (let ((levels slime-autodoc-accuracy-depth))
+	 (slime-parse-form-upto-point levels))))
+
+(defun slime-autodoc--parsing-safe-p ()
+  (cond ((fboundp 'slime-repl-inside-string-or-comment-p)
+	 (not (slime-repl-inside-string-or-comment-p)))
+	(t
+	 (not (slime-inside-string-or-comment-p)))))
+
+(defun slime-autodoc--async (context multilinep)
+  (slime-eval-async
+      `(swank:autodoc ',context ;; FIXME: misuse of quote
+		      :print-right-margin ,(window-width (minibuffer-window)))
+    (slime-curry #'slime-autodoc--async% context multilinep)))
+
+(defun slime-autodoc--async% (context multilinep doc)
+  (cl-destructuring-bind (doc &optional cache-p) doc
+    (unless (eq doc :not-available)
+      (when cache-p
+	(slime-autodoc--cache-put context doc))
+      ;; Now that we've got our information,
+      ;; get it to the user ASAP.
+      (when (eldoc-display-message-p)
+	(eldoc-message (slime-autodoc--format doc multilinep))))))
+
+
+;;; Minor mode definition
+
+;; Compute the prefix for slime-doc-map, usually this is C-c C-d.
+(defun slime-autodoc--doc-map-prefix ()
+  (concat
+   (car (rassoc '(slime-prefix-map) slime-parent-bindings))
+   (car (rassoc '(slime-doc-map) slime-prefix-bindings))))
+
+(define-minor-mode slime-autodoc-mode
+  "Toggle echo area display of Lisp objects at point."
+  :lighter slime-autodoc-mode-string
+  :keymap (let ((prefix (slime-autodoc--doc-map-prefix)))
+	    `((,(concat prefix "A") . slime-autodoc-manually)
+	      (,(concat prefix (kbd "C-A")) . slime-autodoc-manually)
+	      (,(kbd "SPC") . slime-autodoc-space)))
+  (set (make-local-variable 'eldoc-documentation-function) 'slime-autodoc)
+  (set (make-local-variable 'eldoc-minor-mode-string) nil)
+  (setq slime-autodoc-mode (eldoc-mode arg))
+  (when (called-interactively-p 'interactive)
+    (message "Slime autodoc mode %s."
+             (if slime-autodoc-mode "enabled" "disabled"))))
+
+
+;;; Noise to enable/disable slime-autodoc-mode
+
+(defun slime-autodoc--on  () (slime-autodoc-mode 1))
+(defun slime-autodoc--off () (slime-autodoc-mode 0))
+
+(defvar slime-autodoc--relevant-hooks
+  '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook))
+
+(defun slime-autodoc--enable ()
+  (dolist (h slime-autodoc--relevant-hooks)
+    (add-hook h 'slime-autodoc--on))
+  (dolist (b (buffer-list))
+    (with-current-buffer b
+      (when slime-mode
+	(slime-autodoc--on)))))
+
+(defun slime-autodoc--disable ()
+  (dolist (h slime-autodoc--relevant-hooks)
+    (remove-hook h 'slime-autodoc--on))
+  (dolist (b (buffer-list))
+    (with-current-buffer b
+      (when slime-autodoc-mode
+	(slime-autodoc--off)))))
+
+(provide 'slime-autodoc)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-banner.el

@@ -0,0 +1,35 @@
+(require 'slime)
+(require 'slime-repl)
+
+(define-slime-contrib slime-banner
+  "Persistent header line and startup animation."
+  (:authors "Helmut Eller <heller@common-lisp.net>"
+            "Luke Gorrie  <luke@synap.se>")
+  (:license "GPL")
+  (:on-load   (setq slime-repl-banner-function 'slime-startup-message))
+  (:on-unload (setq slime-repl-banner-function 'slime-repl-insert-banner)))
+
+(defcustom slime-startup-animation (fboundp 'animate-string)
+   "Enable the startup animation."
+   :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
+   :group 'slime-ui)
+
+(defcustom slime-header-line-p (boundp 'header-line-format)
+  "If non-nil, display a header line in Slime buffers."
+  :type 'boolean
+  :group 'slime-repl)
+
+(defun slime-startup-message ()
+  (when slime-header-line-p
+    (setq header-line-format 
+          (format "%s  Port: %s  Pid: %s"
+                  (slime-lisp-implementation-type)
+                  (slime-connection-port (slime-connection))
+                  (slime-pid))))
+  (when (zerop (buffer-size))
+    (let ((welcome (concat "; SLIME " slime-version)))
+      (if slime-startup-animation
+          (animate-string welcome 0 0) 
+        (insert welcome)))))
+
+(provide 'slime-banner)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-buffer-streams.el

@@ -0,0 +1,36 @@
+(eval-and-compile
+  (require 'slime))
+
+(define-slime-contrib slime-buffer-streams
+  "Lisp streams that output to an emacs buffer"
+  (:authors "Ed Langley <el-github@elangley.org>")
+  (:license "GPL")
+  (:swank-dependencies swank-buffer-streams))
+
+(defslimefun slime-make-buffer-stream-target (thread name)
+  (message "making target %s" name)
+  (slime-buffer-streams--get-target-marker name)
+  `(:stream-target-created ,thread ,name))
+
+(defun slime-buffer-streams--get-target-name (target)
+  (format "*slime-target %s*" target))
+
+(defvar-local slime-buffer-stream-target nil)
+
+;; TODO: tell backend that the buffer has been closed, so it can close
+;;       the stream
+(defun slime-buffer-streams--cleanup-markers ()
+  (when slime-buffer-stream-target
+    (message "Removing target: %s" slime-buffer-stream-target)
+    (remhash slime-buffer-stream-target slime-output-target-to-marker)))
+
+(defun slime-buffer-streams--get-target-marker (target)
+  (or (gethash target slime-output-target-to-marker)
+      (with-current-buffer
+          (generate-new-buffer (slime-buffer-streams--get-target-name target))
+        (setq slime-buffer-stream-target target)
+        (add-hook 'kill-buffer-hook 'slime-buffer-streams--cleanup-markers)
+        (setf (gethash target slime-output-target-to-marker)
+              (point-marker)))))
+
+(provide 'slime-buffer-streams)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-c-p-c.el

@@ -0,0 +1,305 @@
+(require 'slime)
+(require 'cl-lib)
+
+(defvar slime-c-p-c-init-undo-stack nil)
+
+(define-slime-contrib slime-c-p-c
+  "ILISP style Compound Prefix Completion."
+  (:authors "Luke Gorrie  <luke@synap.se>"
+            "Edi Weitz  <edi@agharta.de>"
+            "Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>"
+            "Tobias C. Rittweiler <tcr@freebits.de>")
+  (:license "GPL")
+  (:slime-dependencies slime-parse slime-editing-commands slime-autodoc)
+  (:swank-dependencies swank-c-p-c)
+  (:on-load
+   (push
+    `(progn
+       (remove-hook 'slime-completion-at-point-functions
+		    #'slime-c-p-c-completion-at-point)
+       (remove-hook 'slime-connected-hook 'slime-c-p-c-on-connect)
+       ,@(when (featurep 'slime-repl)
+               `((define-key slime-mode-map "\C-c\C-s"
+                   ',(lookup-key slime-mode-map "\C-c\C-s"))
+                 (define-key slime-repl-mode-map "\C-c\C-s"
+                   ',(lookup-key slime-repl-mode-map "\C-c\C-s")))))
+    slime-c-p-c-init-undo-stack)
+   (add-hook 'slime-completion-at-point-functions
+	     #'slime-c-p-c-completion-at-point)
+   (define-key slime-mode-map "\C-c\C-s" 'slime-complete-form)
+   (when (featurep 'slime-repl)
+     (define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form)))
+  (:on-unload
+   (while slime-c-p-c-init-undo-stack
+     (eval (pop slime-c-p-c-init-undo-stack)))))
+
+(defcustom slime-c-p-c-unambiguous-prefix-p t
+  "If true, set point after the unambigous prefix.
+If false, move point to the end of the inserted text."
+  :type 'boolean
+  :group 'slime-ui)
+
+(defcustom slime-complete-symbol*-fancy nil
+  "Use information from argument lists for DWIM'ish symbol completion."
+  :group 'slime-mode
+  :type 'boolean)
+
+
+;; FIXME: this is the old code to display completions.  Remove it once
+;; `slime-complete-symbol*' and `slime-fuzzy-complete-symbol' can be
+;; used together with `completion-at-point'.
+
+(defvar slime-completions-buffer-name "*Completions*")
+
+;; FIXME: can probably use quit-window instead
+(make-variable-buffer-local
+ (defvar slime-complete-saved-window-configuration nil
+   "Window configuration before we show the *Completions* buffer.
+This is buffer local in the buffer where the completion is
+performed."))
+
+(make-variable-buffer-local
+ (defvar slime-completions-window nil
+   "The window displaying *Completions* after saving window configuration.
+If this window is no longer active or displaying the completions
+buffer then we can ignore `slime-complete-saved-window-configuration'."))
+
+(defun slime-complete-maybe-save-window-configuration ()
+  "Maybe save the current window configuration.
+Return true if the configuration was saved."
+  (unless (or slime-complete-saved-window-configuration
+              (get-buffer-window slime-completions-buffer-name))
+    (setq slime-complete-saved-window-configuration
+          (current-window-configuration))
+    t))
+
+(defun slime-complete-delay-restoration ()
+  (add-hook 'pre-command-hook
+            'slime-complete-maybe-restore-window-configuration
+            'append
+            'local))
+
+(defun slime-complete-forget-window-configuration ()
+  (setq slime-complete-saved-window-configuration nil)
+  (setq slime-completions-window nil))
+
+(defun slime-complete-restore-window-configuration ()
+  "Restore the window config if available."
+  (remove-hook 'pre-command-hook
+               'slime-complete-maybe-restore-window-configuration)
+  (when (and slime-complete-saved-window-configuration
+             (slime-completion-window-active-p))
+    (save-excursion (set-window-configuration
+                     slime-complete-saved-window-configuration))
+    (setq slime-complete-saved-window-configuration nil)
+    (when (buffer-live-p slime-completions-buffer-name)
+      (kill-buffer slime-completions-buffer-name))))
+
+(defun slime-complete-maybe-restore-window-configuration ()
+  "Restore the window configuration, if the following command
+terminates a current completion."
+  (remove-hook 'pre-command-hook
+               'slime-complete-maybe-restore-window-configuration)
+  (condition-case err
+      (cond ((cl-find last-command-event "()\"'`,# \r\n:")
+             (slime-complete-restore-window-configuration))
+            ((not (slime-completion-window-active-p))
+             (slime-complete-forget-window-configuration))
+            (t
+             (slime-complete-delay-restoration)))
+    (error
+     ;; Because this is called on the pre-command-hook, we mustn't let
+     ;; errors propagate.
+     (message "Error in slime-complete-restore-window-configuration: %S"
+              err))))
+
+(defun slime-completion-window-active-p ()
+  "Is the completion window currently active?"
+  (and (window-live-p slime-completions-window)
+       (equal (buffer-name (window-buffer slime-completions-window))
+              slime-completions-buffer-name)))
+
+(defun slime-display-completion-list (completions start end)
+  (let ((savedp (slime-complete-maybe-save-window-configuration)))
+    (with-output-to-temp-buffer slime-completions-buffer-name
+      (display-completion-list completions)
+      (with-current-buffer standard-output
+        (setq completion-base-position (list start end))
+        (set-syntax-table lisp-mode-syntax-table)))
+    (when savedp
+      (setq slime-completions-window
+            (get-buffer-window slime-completions-buffer-name)))))
+
+(defun slime-display-or-scroll-completions (completions start end)
+  (cond ((and (eq last-command this-command)
+              (slime-completion-window-active-p))
+         (slime-scroll-completions))
+        (t
+         (slime-display-completion-list completions start end)))
+  (slime-complete-delay-restoration))
+
+(defun slime-scroll-completions ()
+  (let ((window slime-completions-window))
+    (with-current-buffer (window-buffer window)
+      (if (pos-visible-in-window-p (point-max) window)
+          (set-window-start window (point-min))
+        (save-selected-window
+          (select-window window)
+          (scroll-up))))))
+
+(defun slime-minibuffer-respecting-message (format &rest format-args)
+  "Display TEXT as a message, without hiding any minibuffer contents."
+  (let ((text (format " [%s]" (apply #'format format format-args))))
+    (if (minibuffer-window-active-p (minibuffer-window))
+        (minibuffer-message text)
+      (message "%s" text))))
+
+(defun slime-maybe-complete-as-filename ()
+   "If point is at a string starting with \", complete it as filename.
+ Return nil if point is not at filename."
+   (when (save-excursion (re-search-backward "\"[^ \t\n]+\\="
+                                            (max (point-min)
+                                                 (- (point) 1000)) t))
+     (let ((comint-completion-addsuffix '("/" . "\"")))
+      (comint-replace-by-expanded-filename)
+      t)))
+
+
+(defun slime-complete-symbol* ()
+  "Expand abbreviations and complete the symbol at point."
+  ;; NB: It is only the name part of the symbol that we actually want
+  ;; to complete -- the package prefix, if given, is just context.
+  (or (slime-maybe-complete-as-filename)
+      (slime-expand-abbreviations-and-complete)))
+
+(defun slime-c-p-c-completion-at-point ()
+  #'slime-complete-symbol*)
+
+;; FIXME: factorize
+(defun slime-expand-abbreviations-and-complete ()
+  (let* ((end (move-marker (make-marker) (slime-symbol-end-pos)))
+         (beg (move-marker (make-marker) (slime-symbol-start-pos)))
+         (prefix (buffer-substring-no-properties beg end))
+         (completion-result (slime-contextual-completions beg end))
+         (completion-set (cl-first completion-result))
+         (completed-prefix (cl-second completion-result)))
+    (if (null completion-set)
+        (progn (slime-minibuffer-respecting-message
+                "Can't find completion for \"%s\"" prefix)
+               (ding)
+               (slime-complete-restore-window-configuration))
+      ;; some XEmacs issue makes this distinction necessary
+      (cond ((> (length completed-prefix) (- end beg))
+	     (goto-char end)
+	     (insert-and-inherit completed-prefix)
+	     (delete-region beg end)
+	     (goto-char (+ beg (length completed-prefix))))
+	    (t nil))
+      (cond ((and (member completed-prefix completion-set)
+                  (slime-length= completion-set 1))
+             (slime-minibuffer-respecting-message "Sole completion")
+             (when slime-complete-symbol*-fancy
+               (slime-complete-symbol*-fancy-bit))
+             (slime-complete-restore-window-configuration))
+            ;; Incomplete
+            (t
+             (when (member completed-prefix completion-set)
+               (slime-minibuffer-respecting-message 
+                "Complete but not unique"))
+	     (when slime-c-p-c-unambiguous-prefix-p
+	       (let ((unambiguous-completion-length
+		      (cl-loop for c in completion-set
+			       minimizing (or (cl-mismatch completed-prefix c)
+                                              (length completed-prefix)))))
+		 (goto-char (+ beg unambiguous-completion-length))))
+             (slime-display-or-scroll-completions completion-set
+                                                  beg
+                                                  (max (point) end)))))))
+
+(defun slime-complete-symbol*-fancy-bit ()
+  "Do fancy tricks after completing a symbol.
+\(Insert a space or close-paren based on arglist information.)"
+  (let ((arglist (slime-retrieve-arglist (slime-symbol-at-point))))
+    (unless (eq arglist :not-available)
+      (let ((args
+             ;; Don't intern these symbols
+             (let ((obarray (make-vector 10 0)))
+               (cdr (read arglist))))
+            (function-call-position-p
+             (save-excursion
+               (backward-sexp)
+               (equal (char-before) ?\())))
+        (when function-call-position-p
+          (if (null args)
+              (execute-kbd-macro ")")
+              (execute-kbd-macro " ")
+              (when (and (slime-background-activities-enabled-p)
+                         (not (minibuffer-window-active-p (minibuffer-window))))
+                (slime-echo-arglist))))))))
+
+(cl-defun slime-contextual-completions (beg end)
+  "Return a list of completions of the token from BEG to END in the
+current buffer."
+  (let ((token (buffer-substring-no-properties beg end)))
+    (cond
+     ((and (< beg (point-max))
+           (string= (buffer-substring-no-properties beg (1+ beg)) ":"))
+      ;; Contextual keyword completion
+      (let ((completions 
+             (slime-completions-for-keyword token
+                                            (save-excursion 
+                                              (goto-char beg)
+                                              (slime-parse-form-upto-point)))))
+        (when (cl-first completions)
+          (cl-return-from slime-contextual-completions completions))
+        ;; If no matching keyword was found, do regular symbol
+        ;; completion.
+        ))
+     ((and (>= (length token) 2)
+           (string= (cl-subseq token 0 2) "#\\"))
+      ;; Character name completion
+      (cl-return-from slime-contextual-completions
+        (slime-completions-for-character token))))
+    ;; Regular symbol completion
+    (slime-completions token)))
+
+(defun slime-completions (prefix)
+  (slime-eval `(swank:completions ,prefix ',(slime-current-package))))
+
+(defun slime-completions-for-keyword (prefix buffer-form)
+  (slime-eval `(swank:completions-for-keyword ,prefix ',buffer-form)))
+
+(defun slime-completions-for-character (prefix)
+  (cl-labels ((append-char-syntax (string) (concat "#\\" string)))
+    (let ((result (slime-eval `(swank:completions-for-character
+                                ,(cl-subseq prefix 2)))))
+      (when (car result)
+        (list (mapcar #'append-char-syntax (car result))
+              (append-char-syntax (cadr result)))))))
+
+
+;;; Complete form
+
+(defun slime-complete-form ()
+  "Complete the form at point.  
+This is a superset of the functionality of `slime-insert-arglist'."
+  (interactive)
+  ;; Find the (possibly incomplete) form around point.
+  (let ((buffer-form (slime-parse-form-upto-point)))
+    (let ((result (slime-eval `(swank:complete-form ',buffer-form))))
+      (if (eq result :not-available)
+          (error "Could not generate completion for the form `%s'" buffer-form)
+          (progn
+            (just-one-space (if (looking-back "\\s(" (1- (point)))
+                                0
+                                1))
+            (save-excursion
+              (insert result)
+              (let ((slime-close-parens-limit 1))
+                (slime-close-all-parens-in-sexp)))
+            (save-excursion
+              (backward-up-list 1)
+              (indent-sexp)))))))
+
+(provide 'slime-c-p-c)
+

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-clipboard.el

@@ -0,0 +1,172 @@
+(require 'slime)
+(require 'slime-repl)
+(require 'cl-lib)
+(eval-when-compile
+  (require 'cl)) ; lexical-let
+
+(define-slime-contrib slime-clipboard
+  "This add a few commands to put objects into a clipboard and to
+insert textual references to those objects.
+
+The clipboard command prefix is C-c @.
+
+ C-c @ +   adds an object to the clipboard
+ C-c @ @   inserts a reference to an object in the clipboard
+ C-c @ ?   displays the clipboard
+
+This package also also binds the + key in the inspector and
+debugger to add the object at point to the clipboard."
+  (:authors "Helmut Eller  <heller@common-lisp.net>")
+  (:license "GPL")
+  (:swank-dependencies swank-clipboard))
+
+(define-derived-mode slime-clipboard-mode fundamental-mode
+  "Slime-Clipboard"
+  "SLIME Clipboad Mode.
+
+\\{slime-clipboard-mode-map}")
+
+(slime-define-keys slime-clipboard-mode-map
+  ("g" 'slime-clipboard-redisplay)
+  ((kbd "C-k") 'slime-clipboard-delete-entry)
+  ("i" 'slime-clipboard-inspect))
+
+(defvar slime-clipboard-map (make-sparse-keymap))
+
+(slime-define-keys slime-clipboard-map
+  ("?" 'slime-clipboard-display)
+  ("+" 'slime-clipboard-add)
+  ("@" 'slime-clipboard-ref))
+
+(define-key slime-mode-map (kbd "C-c @") slime-clipboard-map)
+(define-key slime-repl-mode-map (kbd "C-c @") slime-clipboard-map)
+
+(slime-define-keys slime-inspector-mode-map
+  ("+" 'slime-clipboard-add-from-inspector))
+
+(slime-define-keys sldb-mode-map
+  ("+" 'slime-clipboard-add-from-sldb))
+
+(defun slime-clipboard-add (exp package)
+  "Add an object to the clipboard."
+  (interactive (list (slime-read-from-minibuffer 
+                      "Add to clipboard (evaluated): "
+                      (slime-sexp-at-point))
+		     (slime-current-package)))
+  (slime-clipboard-add-internal `(:string ,exp ,package)))
+
+(defun slime-clipboard-add-internal (datum)
+  (slime-eval-async `(swank-clipboard:add ',datum) 
+		    (lambda (result) (message "%s" result))))
+
+(defun slime-clipboard-display ()
+  "Display the content of the clipboard."
+  (interactive)
+  (slime-eval-async `(swank-clipboard:entries) 
+		    #'slime-clipboard-display-entries))
+
+(defun slime-clipboard-display-entries (entries)
+  (slime-with-popup-buffer ((slime-buffer-name :clipboard)
+                            :mode 'slime-clipboard-mode)
+    (slime-clipboard-insert-entries entries)))
+
+(defun slime-clipboard-insert-entries (entries)
+  (let ((fstring "%2s %3s %s\n"))
+    (insert (format fstring "Nr" "Id" "Value")
+            (format fstring "--" "--" "-----" ))
+    (save-excursion
+      (cl-loop for i from 0 for (ref . value) in entries do
+               (slime-insert-propertized `(slime-clipboard-entry ,i
+                                           slime-clipboard-ref ,ref)
+                                         (format fstring i ref value))))))
+
+(defun slime-clipboard-redisplay ()
+  "Update the clipboard buffer."
+  (interactive)
+  (lexical-let ((saved (point)))
+    (slime-eval-async 
+        `(swank-clipboard:entries) 
+      (lambda (entries) 
+        (let ((inhibit-read-only t))
+          (erase-buffer)
+          (slime-clipboard-insert-entries entries)
+          (when (< saved (point-max))
+            (goto-char saved)))))))
+
+(defun slime-clipboard-entry-at-point ()
+  (or (get-text-property (point) 'slime-clipboard-entry)
+      (error "No clipboard entry at point")))
+
+(defun slime-clipboard-ref-at-point ()
+  (or (get-text-property (point) 'slime-clipboard-ref)
+      (error "No clipboard ref at point")))
+
+(defun slime-clipboard-inspect (&optional entry)
+  "Inspect the current clipboard entry."
+  (interactive (list (slime-clipboard-ref-at-point)))
+  (slime-inspect (prin1-to-string `(swank-clipboard::clipboard-ref ,entry))))
+
+(defun slime-clipboard-delete-entry (&optional entry)
+  "Delete the current entry from the clipboard."
+  (interactive (list (slime-clipboard-entry-at-point)))
+  (slime-eval-async `(swank-clipboard:delete-entry ,entry)
+		    (lambda (result) 
+		      (slime-clipboard-redisplay)
+		      (message "%s" result))))
+
+(defun slime-clipboard-ref ()
+  "Ask for a clipboard entry number and insert a reference to it."
+  (interactive)
+  (slime-clipboard-read-entry-number #'slime-clipboard-insert-ref))
+  
+;; insert a reference to clipboard entry ENTRY at point.  The text
+;; receives a special 'display property to make it look nicer.  We
+;; remove this property in a modification when a user tries to modify
+;; he real text.
+(defun slime-clipboard-insert-ref (entry)
+  (cl-destructuring-bind (ref . string) 
+      (slime-eval `(swank-clipboard:entry-to-ref ,entry))
+    (slime-insert-propertized
+     `(display ,(format "#@%d%s" ref string)
+	       modification-hooks (slime-clipboard-ref-modified)
+	       rear-nonsticky t)
+     (format "(swank-clipboard::clipboard-ref %d)" ref))))
+
+(defun slime-clipboard-ref-modified (start end)
+  (when (get-text-property start 'display)
+    (let ((inhibit-modification-hooks t))
+      (save-excursion
+	(goto-char start)
+	(cl-destructuring-bind (dstart dend) (slime-property-bounds 'display)
+	  (unless (and (= start dstart) (= end dend))
+	    (remove-list-of-text-properties 
+	     dstart dend '(display modification-hooks))))))))
+
+;; Read a entry number.
+;; Written in CPS because the display the clipboard before reading.
+(defun slime-clipboard-read-entry-number (k)
+  (slime-eval-async 
+   `(swank-clipboard:entries) 
+   (slime-rcurry
+    (lambda (entries window-config k)
+      (slime-clipboard-display-entries entries)
+      (let ((entry (unwind-protect
+		       (read-from-minibuffer "Entry number: " nil nil t)
+		     (set-window-configuration window-config))))
+	(funcall k entry)))
+    (current-window-configuration)
+    k)))
+
+(defun slime-clipboard-add-from-inspector ()
+  (interactive)
+  (let ((part (or (get-text-property (point) 'slime-part-number)
+		  (error "No part at point"))))
+    (slime-clipboard-add-internal `(:inspector ,part))))
+
+(defun slime-clipboard-add-from-sldb ()
+  (interactive)
+  (slime-clipboard-add-internal 
+   `(:sldb ,(sldb-frame-number-at-point) 
+	   ,(sldb-var-number-at-point))))
+
+(provide 'slime-clipboard)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-compiler-notes-tree.el

@@ -0,0 +1,184 @@
+(require 'slime)
+(require 'cl-lib)
+
+(define-slime-contrib slime-compiler-notes-tree
+  "Display compiler messages in tree layout.
+
+M-x slime-list-compiler-notes display the compiler notes in a tree
+grouped by severity.
+
+  `slime-maybe-list-compiler-notes' can be used as
+  `slime-compilation-finished-hook'.
+"
+  (:authors "Helmut Eller <heller@common-lisp.net>")
+  (:license "GPL"))
+
+(defun slime-maybe-list-compiler-notes (notes)
+  "Show the compiler notes if appropriate."
+  ;; don't pop up a buffer if all notes are already annotated in the
+  ;; buffer itself
+  (unless (cl-every #'slime-note-has-location-p notes)
+    (slime-list-compiler-notes notes)))
+
+(defun slime-list-compiler-notes (notes)
+  "Show the compiler notes NOTES in tree view."
+  (interactive (list (slime-compiler-notes)))
+  (with-temp-message "Preparing compiler note tree..."
+    (slime-with-popup-buffer ((slime-buffer-name :notes)
+                              :mode 'slime-compiler-notes-mode)
+      (when (null notes)
+        (insert "[no notes]"))
+      (let ((collapsed-p))
+        (dolist (tree (slime-compiler-notes-to-tree notes))
+          (when (slime-tree.collapsed-p tree) (setf collapsed-p t))
+          (slime-tree-insert tree "")
+          (insert "\n"))
+        (goto-char (point-min))))))
+
+(defvar slime-tree-printer 'slime-tree-default-printer)
+
+(defun slime-tree-for-note (note)
+  (make-slime-tree :item (slime-note.message note)
+                   :plist (list 'note note)
+                   :print-fn slime-tree-printer))
+
+(defun slime-tree-for-severity (severity notes collapsed-p)
+  (make-slime-tree :item (format "%s (%d)" 
+                                 (slime-severity-label severity)
+                                 (length notes))
+                   :kids (mapcar #'slime-tree-for-note notes)
+                   :collapsed-p collapsed-p))
+
+(defun slime-compiler-notes-to-tree (notes)
+  (let* ((alist (slime-alistify notes #'slime-note.severity #'eq))
+         (collapsed-p (slime-length> alist 1)))
+    (cl-loop for (severity . notes) in alist
+             collect (slime-tree-for-severity severity notes 
+                                              collapsed-p))))
+
+(defvar slime-compiler-notes-mode-map)
+
+(define-derived-mode slime-compiler-notes-mode fundamental-mode 
+  "Compiler-Notes"
+  "\\<slime-compiler-notes-mode-map>\
+\\{slime-compiler-notes-mode-map}
+\\{slime-popup-buffer-mode-map}
+"
+  (slime-set-truncate-lines))
+
+(slime-define-keys slime-compiler-notes-mode-map
+  ((kbd "RET") 'slime-compiler-notes-default-action-or-show-details)
+  ([return] 'slime-compiler-notes-default-action-or-show-details)
+  ([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse))
+
+(defun slime-compiler-notes-default-action-or-show-details/mouse (event)
+  "Invoke the action pointed at by the mouse, or show details."
+  (interactive "e")
+  (cl-destructuring-bind (mouse-2 (w pos &rest _) &rest __) event
+    (save-excursion
+      (goto-char pos)
+      (let ((fn (get-text-property (point) 
+                                   'slime-compiler-notes-default-action)))
+	(if fn (funcall fn) (slime-compiler-notes-show-details))))))
+
+(defun slime-compiler-notes-default-action-or-show-details ()
+  "Invoke the action at point, or show details."
+  (interactive)
+  (let ((fn (get-text-property (point) 'slime-compiler-notes-default-action)))
+    (if fn (funcall fn) (slime-compiler-notes-show-details))))
+
+(defun slime-compiler-notes-show-details ()
+  (interactive)
+  (let* ((tree (slime-tree-at-point))
+         (note (plist-get (slime-tree.plist tree) 'note))
+         (inhibit-read-only t))
+    (cond ((not (slime-tree-leaf-p tree))
+           (slime-tree-toggle tree))
+          (t
+           (slime-show-source-location (slime-note.location note) t)))))
+
+
+;;;;;; Tree Widget
+
+(cl-defstruct (slime-tree (:conc-name slime-tree.))
+  item
+  (print-fn #'slime-tree-default-printer :type function)
+  (kids '() :type list)
+  (collapsed-p t :type boolean)
+  (prefix "" :type string)
+  (start-mark nil)
+  (end-mark nil)
+  (plist '() :type list))
+
+(defun slime-tree-leaf-p (tree)
+  (not (slime-tree.kids tree)))
+
+(defun slime-tree-default-printer (tree)
+  (princ (slime-tree.item tree) (current-buffer)))
+
+(defun slime-tree-decoration (tree)
+  (cond ((slime-tree-leaf-p tree) "-- ")
+	((slime-tree.collapsed-p tree) "[+] ")
+	(t "-+  ")))
+
+(defun slime-tree-insert-list (list prefix)
+  "Insert a list of trees."
+  (cl-loop for (elt . rest) on list 
+           do (cond (rest
+                     (insert prefix " |")
+                     (slime-tree-insert elt (concat prefix " |"))
+                     (insert "\n"))
+                    (t
+                     (insert prefix " `")
+                     (slime-tree-insert elt (concat prefix "  "))))))
+
+(defun slime-tree-insert-decoration (tree)
+  (insert (slime-tree-decoration tree)))
+
+(defun slime-tree-indent-item (start end prefix)
+  "Insert PREFIX at the beginning of each but the first line.
+This is used for labels spanning multiple lines."
+  (save-excursion
+    (goto-char end)
+    (beginning-of-line)
+    (while (< start (point))
+      (insert-before-markers prefix)
+      (forward-line -1))))
+
+(defun slime-tree-insert (tree prefix)
+  "Insert TREE prefixed with PREFIX at point."
+  (with-struct (slime-tree. print-fn kids collapsed-p start-mark end-mark) tree
+    (let ((line-start (line-beginning-position)))
+      (setf start-mark (point-marker))
+      (slime-tree-insert-decoration tree)
+      (funcall print-fn tree)
+      (slime-tree-indent-item start-mark (point) (concat prefix "   "))
+      (add-text-properties line-start (point) (list 'slime-tree tree))
+      (set-marker-insertion-type start-mark t)
+      (when (and kids (not collapsed-p))
+        (terpri (current-buffer))
+        (slime-tree-insert-list kids prefix))
+      (setf (slime-tree.prefix tree) prefix)
+      (setf end-mark (point-marker)))))
+
+(defun slime-tree-at-point ()
+  (cond ((get-text-property (point) 'slime-tree))
+        (t (error "No tree at point"))))
+
+(defun slime-tree-delete (tree)
+  "Delete the region for TREE."
+  (delete-region (slime-tree.start-mark tree)
+                 (slime-tree.end-mark tree)))
+
+(defun slime-tree-toggle (tree)
+  "Toggle the visibility of TREE's children."
+  (with-struct (slime-tree. collapsed-p start-mark end-mark prefix) tree
+    (setf collapsed-p (not collapsed-p))
+    (slime-tree-delete tree)
+    (insert-before-markers " ") ; move parent's end-mark
+    (backward-char 1)
+    (slime-tree-insert tree prefix)
+    (delete-char 1)
+    (goto-char start-mark)))
+
+(provide 'slime-compiler-notes-tree)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-editing-commands.el

@@ -0,0 +1,183 @@
+(require 'slime)
+(require 'slime-repl)
+(require 'cl-lib)
+
+(define-slime-contrib slime-editing-commands
+  "Editing commands without server interaction."
+  (:authors "Thomas F. Burdick  <tfb@OCF.Berkeley.EDU>"
+            "Luke Gorrie  <luke@synap.se>"
+            "Bill Clementson <billclem@gmail.com>"
+            "Tobias C. Rittweiler <tcr@freebits.de>")
+  (:license "GPL")
+  (:on-load
+   (define-key slime-mode-map "\M-\C-a"  'slime-beginning-of-defun)
+   (define-key slime-mode-map "\M-\C-e"  'slime-end-of-defun)
+   (define-key slime-mode-map "\C-c\M-q" 'slime-reindent-defun)
+   (define-key slime-mode-map "\C-c\C-]" 'slime-close-all-parens-in-sexp)))
+
+(defun slime-beginning-of-defun ()
+  (interactive)
+  (if (and (boundp 'slime-repl-input-start-mark)
+           slime-repl-input-start-mark)
+      (slime-repl-beginning-of-defun)
+    (let ((this-command 'beginning-of-defun)) ; needed for push-mark
+      (call-interactively 'beginning-of-defun))))
+
+(defun slime-end-of-defun ()
+  (interactive)
+  (if (eq major-mode 'slime-repl-mode)
+      (slime-repl-end-of-defun)
+      (end-of-defun)))
+
+(defvar slime-comment-start-regexp
+  "\\(\\(^\\|[^\n\\\\]\\)\\([\\\\][\\\\]\\)*\\);+[ \t]*"
+  "Regexp to match the start of a comment.")
+
+(defun slime-beginning-of-comment ()
+  "Move point to beginning of comment.
+If point is inside a comment move to beginning of comment and return point.
+Otherwise leave point unchanged and return NIL."
+  (let ((boundary (point)))
+    (beginning-of-line)
+    (cond ((re-search-forward slime-comment-start-regexp boundary t)
+           (point))
+          (t (goto-char boundary) 
+             nil))))
+
+(defvar slime-close-parens-limit nil
+  "Maxmimum parens for `slime-close-all-sexp' to insert. NIL
+means to insert as many parentheses as necessary to correctly
+close the form.")
+
+(defun slime-close-all-parens-in-sexp (&optional region)
+  "Balance parentheses of open s-expressions at point.
+Insert enough right parentheses to balance unmatched left parentheses.
+Delete extra left parentheses.  Reformat trailing parentheses 
+Lisp-stylishly.
+
+If REGION is true, operate on the region. Otherwise operate on
+the top-level sexp before point."
+  (interactive "P")
+  (let ((sexp-level 0)
+        point)
+    (save-excursion
+      (save-restriction
+        (when region
+          (narrow-to-region (region-beginning) (region-end))
+          (goto-char (point-max)))
+        ;; skip over closing parens, but not into comment
+        (skip-chars-backward ") \t\n")
+        (when (slime-beginning-of-comment)
+          (forward-line)
+          (skip-chars-forward " \t"))
+        (setq point (point))
+        ;; count sexps until either '(' or comment is found at first column
+        (while (and (not (looking-at "^[(;]"))
+		    (ignore-errors (backward-up-list 1) t))
+          (incf sexp-level))))
+    (when (> sexp-level 0)
+      ;; insert correct number of right parens
+      (goto-char point)
+      (dotimes (i sexp-level) (insert ")"))
+      ;; delete extra right parens
+      (setq point (point))
+      (skip-chars-forward " \t\n)")
+      (skip-chars-backward " \t\n")
+      (let* ((deleted-region     (delete-and-extract-region point (point)))
+             (deleted-text       (substring-no-properties deleted-region))
+             (prior-parens-count (cl-count ?\) deleted-text)))
+        ;; Remember: we always insert as many parentheses as necessary
+        ;; and only afterwards delete the superfluously-added parens.
+        (when slime-close-parens-limit
+          (let ((missing-parens (- sexp-level prior-parens-count
+                                   slime-close-parens-limit)))
+            (dotimes (i (max 0 missing-parens))
+              (delete-char -1))))))))
+
+(defun slime-insert-balanced-comments (arg)
+  "Insert a set of balanced comments around the s-expression
+containing the point.  If this command is invoked repeatedly
+\(without any other command occurring between invocations), the
+comment progressively moves outward over enclosing expressions.
+If invoked with a positive prefix argument, the s-expression arg
+expressions out is enclosed in a set of balanced comments."
+  (interactive "*p")
+  (save-excursion
+    (when (eq last-command this-command)
+      (when (search-backward "#|" nil t)
+        (save-excursion
+          (delete-char 2)
+          (while (and (< (point) (point-max)) (not (looking-at " *|#")))
+            (forward-sexp))
+          (replace-match ""))))
+    (while (> arg 0)
+      (backward-char 1)
+      (cond ((looking-at ")") (incf arg))
+            ((looking-at "(") (decf arg))))
+    (insert "#|")
+    (forward-sexp)
+    (insert "|#")))
+
+(defun slime-remove-balanced-comments ()
+  "Remove a set of balanced comments enclosing point."
+  (interactive "*")
+  (save-excursion
+    (when (search-backward "#|" nil t)
+      (delete-char 2)
+      (while (and (< (point) (point-max)) (not (looking-at " *|#")))
+      (forward-sexp))
+      (replace-match ""))))
+
+
+;; SLIME-CLOSE-PARENS-AT-POINT is obsolete:
+
+;; It doesn't work correctly on the REPL, because there
+;; BEGINNING-OF-DEFUN-FUNCTION and END-OF-DEFUN-FUNCTION is bound to
+;; SLIME-REPL-MODE-BEGINNING-OF-DEFUN (and
+;; SLIME-REPL-MODE-END-OF-DEFUN respectively) which compromises the
+;; way how they're expect to work (i.e. END-OF-DEFUN does not signal
+;; an UNBOUND-PARENTHESES error.)
+
+;; Use SLIME-CLOSE-ALL-PARENS-IN-SEXP instead.
+
+;; (defun slime-close-parens-at-point ()
+;;   "Close parenthesis at point to complete the top-level-form.  Simply
+;; inserts ')' characters at point until `beginning-of-defun' and
+;; `end-of-defun' execute without errors, or `slime-close-parens-limit'
+;; is exceeded."
+;;   (interactive)
+;;   (loop for i from 1 to slime-close-parens-limit
+;;         until (save-excursion
+;;                 (slime-beginning-of-defun)
+;;                 (ignore-errors (slime-end-of-defun) t))
+;;         do (insert ")")))
+
+(defun slime-reindent-defun (&optional force-text-fill)
+  "Reindent the current defun, or refill the current paragraph.
+If point is inside a comment block, the text around point will be
+treated as a paragraph and will be filled with `fill-paragraph'.
+Otherwise, it will be treated as Lisp code, and the current defun
+will be reindented.  If the current defun has unbalanced parens,
+an attempt will be made to fix it before reindenting.
+
+When given a prefix argument, the text around point will always
+be treated as a paragraph.  This is useful for filling docstrings."
+  (interactive "P")
+  (save-excursion
+    (if (or force-text-fill (slime-beginning-of-comment))
+        (fill-paragraph nil)
+      (let ((start (progn (unless (or (and (zerop (current-column))
+                                           (eq ?\( (char-after)))
+                                      (and slime-repl-input-start-mark
+                                           (slime-repl-at-prompt-start-p)))
+                            (slime-beginning-of-defun))
+                          (point)))
+            (end (ignore-errors (slime-end-of-defun) (point))))
+        (unless end
+          (forward-paragraph)
+          (slime-close-all-parens-in-sexp)
+          (slime-end-of-defun)
+          (setf end (point)))
+        (indent-region start end nil)))))
+
+(provide 'slime-editing-commands)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-enclosing-context.el

@@ -0,0 +1,226 @@
+(require 'slime)
+(require 'slime-parse)
+(require 'cl-lib)
+
+(define-slime-contrib slime-enclosing-context
+  "Utilities on top of slime-parse."
+  (:authors "Tobias C. Rittweiler <tcr@freebits.de>")
+  (:license "GPL"))
+
+(defun slime-parse-sexp-at-point (&optional n)
+  "Returns the sexps at point as a list of strings, otherwise nil.
+\(If there are not as many sexps as N, a list with < N sexps is
+returned.\)
+If SKIP-BLANKS-P is true, leading whitespaces &c are skipped.
+"
+  (interactive "p") (or n (setq n 1))
+  (save-excursion
+    (let ((result nil))
+      (dotimes (i n)
+        ;; Is there an additional sexp in front of us?
+        (save-excursion
+          (unless (slime-point-moves-p (ignore-errors (forward-sexp)))
+            (cl-return)))
+        (push (slime-sexp-at-point) result)
+        ;; Skip current sexp
+        (ignore-errors (forward-sexp) (skip-chars-forward "[:space:]")))
+      (nreverse result))))
+
+(defun slime-has-symbol-syntax-p (string)
+  (if (and string (not (zerop (length string))))
+      (member (char-syntax (aref string 0))
+ '(?w ?_ ?\' ?\\))))
+
+(defun slime-beginning-of-string ()
+  (let* ((parser-state (slime-current-parser-state))
+	 (inside-string-p  (nth 3 parser-state))
+	 (string-start-pos (nth 8 parser-state)))
+    (if inside-string-p
+        (goto-char string-start-pos)
+      (error "We're not within a string"))))
+
+(defun slime-enclosing-form-specs (&optional max-levels)
+  "Return the list of ``raw form specs'' of all the forms
+containing point from right to left.
+
+As a secondary value, return a list of indices: Each index tells
+for each corresponding form spec in what argument position the
+user's point is.
+
+As tertiary value, return the positions of the operators that are
+contained in the returned form specs.
+
+When MAX-LEVELS is non-nil, go up at most this many levels of
+parens.
+
+\(See SWANK::PARSE-FORM-SPEC for more information about what
+exactly constitutes a ``raw form specs'')
+
+Examples:
+
+  A return value like the following
+
+    (values  ((\"quux\") (\"bar\") (\"foo\")) (3 2 1) (p1 p2 p3))
+
+  can be interpreted as follows:
+
+    The user point is located in the 3rd argument position of a
+    form with the operator name \"quux\" (which starts at P1.)
+
+    This form is located in the 2nd argument position of a form
+    with the operator name \"bar\" (which starts at P2.)
+
+    This form again is in the 1st argument position of a form
+    with the operator name \"foo\" (which itself begins at P3.)
+
+  For instance, the corresponding buffer content could have looked
+  like `(foo (bar arg1 (quux 1 2 |' where `|' denotes point.
+"
+  (let ((level 1)
+        (parse-sexp-lookup-properties nil)
+        (initial-point (point))
+        (result '()) (arg-indices '()) (points '()))
+    ;; The expensive lookup of syntax-class text properties is only
+    ;; used for interactive balancing of #<...> in presentations; we
+    ;; do not need them in navigating through the nested lists.
+    ;; This speeds up this function significantly.
+    (ignore-errors
+      (save-excursion
+        ;; Make sure we get the whole thing at point.
+        (if (not (slime-inside-string-p))
+            (slime-end-of-symbol)
+          (slime-beginning-of-string)
+          (forward-sexp))
+        (save-restriction
+          ;; Don't parse more than 20000 characters before point, so we don't spend
+          ;; too much time.
+          (narrow-to-region (max (point-min) (- (point) 20000)) (point-max))
+          (narrow-to-region (save-excursion (beginning-of-defun) (point))
+                            (min (1+ (point)) (point-max)))
+          (while (or (not max-levels)
+                     (<= level max-levels))
+            (let ((arg-index 0))
+              ;; Move to the beginning of the current sexp if not already there.
+              (if (or (and (char-after)
+                           (member (char-syntax (char-after)) '(?\( ?')))
+                      (member (char-syntax (char-before)) '(?\  ?>)))
+                  (cl-incf arg-index))
+              (ignore-errors (backward-sexp 1))
+              (while (and (< arg-index 64)
+                          (ignore-errors (backward-sexp 1)
+                                         (> (point) (point-min))))
+                (cl-incf arg-index))
+              (backward-up-list 1)
+              (when (member (char-syntax (char-after)) '(?\( ?'))
+                (cl-incf level)
+                (forward-char 1)
+                (let ((name (slime-symbol-at-point)))
+                  (push (and name `(,name)) result)
+                  (push arg-index arg-indices)
+                  (push (point) points))
+                (backward-up-list 1)))))))
+    (cl-values
+     (nreverse result)
+     (nreverse arg-indices)
+ (nreverse points))))
+
+(defvar slime-variable-binding-ops-alist
+  '((let &bindings &body)
+    (let* &bindings &body)))
+
+(defvar slime-function-binding-ops-alist
+  '((flet &bindings &body)
+    (labels &bindings &body)
+    (macrolet &bindings &body)))
+
+(defun slime-lookup-binding-op (op &optional binding-type)
+  (cl-labels ((lookup-in (list) (cl-assoc op list :test 'cl-equalp :key 'symbol-name)))
+    (cond ((eq binding-type :variable) (lookup-in slime-variable-binding-ops-alist))
+	  ((eq binding-type :function) (lookup-in slime-function-binding-ops-alist))
+	  (t (or (lookup-in slime-variable-binding-ops-alist)
+		 (lookup-in slime-function-binding-ops-alist))))))
+
+(defun slime-binding-op-p (op &optional binding-type)
+  (and (slime-lookup-binding-op op binding-type) t))
+
+(defun slime-binding-op-body-pos (op)
+  (let ((special-lambda-list (slime-lookup-binding-op op)))
+    (if special-lambda-list (cl-position '&body special-lambda-list))))
+
+(defun slime-binding-op-bindings-pos (op)
+  (let ((special-lambda-list (slime-lookup-binding-op op)))
+    (if special-lambda-list (cl-position '&bindings special-lambda-list))))
+
+(defun slime-enclosing-bound-names ()
+  "Returns all bound function names as first value, and the
+points where their bindings are established as second value."
+  (cl-multiple-value-call #'slime-find-bound-names
+                          (slime-enclosing-form-specs)))
+
+(defun slime-find-bound-names (ops indices points)
+  (let ((binding-names) (binding-start-points))
+    (save-excursion
+      (cl-loop for (op . nil) in ops
+               for index in indices
+               for point in points
+               do (when (and (slime-binding-op-p op)
+                             ;; Are the bindings of OP in scope?
+                             (>= index (slime-binding-op-body-pos op)))
+                    (goto-char point)
+                    (forward-sexp (slime-binding-op-bindings-pos op))
+                    (down-list)
+                    (ignore-errors
+                      (cl-loop
+                       (down-list)
+                       (push (slime-symbol-at-point) binding-names)
+                       (push (save-excursion (backward-up-list) (point))
+                             binding-start-points)
+                       (up-list)))))
+      (cl-values (nreverse binding-names) (nreverse binding-start-points)))))
+
+
+(defun slime-enclosing-bound-functions ()
+  (cl-multiple-value-call #'slime-find-bound-functions
+                          (slime-enclosing-form-specs)))
+
+(defun slime-find-bound-functions (ops indices points)
+  (let ((names) (arglists) (start-points))
+    (save-excursion
+      (cl-loop for (op . nil) in ops
+               for index in indices
+               for point in points
+               do (when (and (slime-binding-op-p op :function)
+                             ;; Are the bindings of OP in scope?
+                             (>= index (slime-binding-op-body-pos op)))
+                    (goto-char point)
+                    (forward-sexp (slime-binding-op-bindings-pos op))
+                    (down-list)
+                    ;; If we're at the end of the bindings, an error will
+                    ;; be signalled by the `down-list' below.
+                    (ignore-errors
+                      (cl-loop
+                       (down-list)
+                       (cl-destructuring-bind (name arglist)
+                           (slime-parse-sexp-at-point 2)
+                         (cl-assert (slime-has-symbol-syntax-p name))
+                         (cl-assert arglist)
+                         (push name names)
+                         (push arglist arglists)
+                         (push (save-excursion (backward-up-list) (point))
+                               start-points))
+                       (up-list)))))
+      (cl-values (nreverse names)
+                 (nreverse arglists)
+                 (nreverse start-points)))))
+
+
+(defun slime-enclosing-bound-macros ()
+  (cl-multiple-value-call #'slime-find-bound-macros
+                          (slime-enclosing-form-specs)))
+
+(defun slime-find-bound-macros (ops indices points)
+  ;; Kludgy!
+  (let ((slime-function-binding-ops-alist '((macrolet &bindings &body))))
+    (slime-find-bound-functions ops indices points)))
+
+(provide 'slime-enclosing-context)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy-inspector.el

@@ -0,0 +1,42 @@
+(eval-and-compile
+  (require 'slime))
+
+(define-slime-contrib slime-fancy-inspector
+  "Fancy inspector for CLOS objects."
+  (:authors "Marco Baringer <mb@bese.it> and others")
+  (:license "GPL")
+  (:slime-dependencies slime-parse)
+  (:swank-dependencies swank-fancy-inspector)
+  (:on-load
+   (add-hook 'slime-edit-definition-hooks 'slime-edit-inspector-part))
+  (:on-unload
+   (remove-hook 'slime-edit-definition-hooks 'slime-edit-inspector-part)))
+
+(defun slime-inspect-definition ()
+  "Inspect definition at point"
+  (interactive)
+  (slime-inspect (slime-definition-at-point)))
+
+(defun slime-disassemble-definition ()
+  "Disassemble definition at point"
+  (interactive)
+  (slime-eval-describe `(swank:disassemble-form
+                         ,(slime-definition-at-point t))))
+
+(defun slime-edit-inspector-part (name &optional where)
+  (and (eq major-mode 'slime-inspector-mode)
+       (cl-destructuring-bind (&optional property value)
+           (slime-inspector-property-at-point)
+         (when (eq property 'slime-part-number)
+           (let ((location (slime-eval `(swank:find-definition-for-thing
+                                         (swank:inspector-nth-part ,value))))
+                 (name (format "Inspector part %s" value)))
+             (when (and (consp location)
+                        (not (eq (car location) :error)))
+               (slime-edit-definition-cont
+                (list (make-slime-xref :dspec `(,name)
+                                       :location location))
+                name
+                where)))))))
+
+(provide 'slime-fancy-inspector)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy-trace.el

@@ -0,0 +1,68 @@
+(eval-and-compile
+  (require 'slime))
+
+(define-slime-contrib slime-fancy-trace
+  "Enhanced version of slime-trace capable of tracing local functions,
+methods, setf functions, and other entities supported by specific
+swank:swank-toggle-trace backends. Invoke via C-u C-t."
+  (:authors "Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>"
+            "Tobias C. Rittweiler <tcr@freebits.de>")
+  (:license "GPL")
+  (:slime-dependencies slime-parse))
+
+(defun slime-trace-query (spec)
+  "Ask the user which function to trace; SPEC is the default.
+The result is a string."
+  (cond ((null spec)
+         (slime-read-from-minibuffer "(Un)trace: "))
+        ((stringp spec)
+         (slime-read-from-minibuffer "(Un)trace: " spec))
+        ((symbolp spec)    ; `slime-extract-context' can return symbols.
+         (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
+        (t
+         (slime-dcase spec
+           ((setf n)
+            (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
+           ((:defun n)
+            (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n)))
+           ((:defgeneric n)
+            (let* ((name (prin1-to-string n))
+                   (answer (slime-read-from-minibuffer "(Un)trace: " name)))
+              (cond ((and (string= name answer)
+                          (y-or-n-p (concat "(Un)trace also all "
+                                            "methods implementing "
+                                            name "? ")))
+                     (prin1-to-string `(:defgeneric ,n)))
+                    (t
+                     answer))))
+           ((:defmethod &rest _)
+            (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
+           ((:call caller callee)
+            (let* ((callerstr (prin1-to-string caller))
+                   (calleestr (prin1-to-string callee))
+                   (answer (slime-read-from-minibuffer "(Un)trace: "
+                                                       calleestr)))
+              (cond ((and (string= calleestr answer)
+                          (y-or-n-p (concat "(Un)trace only when " calleestr
+                                            " is called by " callerstr "? ")))
+                     (prin1-to-string `(:call ,caller ,callee)))
+                    (t
+                     answer))))
+           (((:labels :flet) &rest _)
+            (slime-read-from-minibuffer "(Un)trace local function: "
+                                        (prin1-to-string spec)))
+           (t (error "Don't know how to trace the spec %S" spec))))))
+
+(defun slime-toggle-fancy-trace (&optional using-context-p)
+  "Toggle trace."
+  (interactive "P")
+  (let* ((spec (if using-context-p
+                   (slime-extract-context)
+                   (slime-symbol-at-point)))
+         (spec (slime-trace-query spec)))
+    (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec)))))
+
+;; override slime-toggle-trace-fdefinition
+(define-key slime-prefix-map "\C-t" 'slime-toggle-fancy-trace)
+
+(provide 'slime-fancy-trace)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy.el

@@ -0,0 +1,38 @@
+(require 'slime)
+
+(define-slime-contrib slime-fancy
+  "Make SLIME fancy."
+  (:authors "Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>"
+            "Tobias C Rittweiler <tcr@freebits.de>")
+  (:license "GPL")
+  (:slime-dependencies slime-repl
+                       slime-autodoc
+                       slime-c-p-c
+                       slime-editing-commands
+                       slime-fancy-inspector
+                       slime-fancy-trace
+                       slime-fuzzy
+                       slime-mdot-fu
+                       slime-macrostep
+                       slime-presentations
+                       slime-scratch
+                       slime-references
+                       slime-package-fu
+                       slime-fontifying-fu
+                       slime-trace-dialog)
+  (:on-load
+   (slime-trace-dialog-init)
+   (slime-repl-init)
+   (slime-autodoc-init)
+   (slime-c-p-c-init)
+   (slime-editing-commands-init)
+   (slime-fancy-inspector-init)
+   (slime-fancy-trace-init)
+   (slime-fuzzy-init)
+   (slime-presentations-init)
+   (slime-scratch-init)
+   (slime-references-init)
+   (slime-package-fu-init)
+   (slime-fontifying-fu-init)))
+
+(provide 'slime-fancy)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fontifying-fu.el

@@ -0,0 +1,231 @@
+(require 'slime)
+(require 'slime-parse)
+(require 'slime-autodoc)
+(require 'font-lock)
+(require 'cl-lib)
+
+;;; Fontify WITH-FOO, DO-FOO, and DEFINE-FOO like standard macros.
+;;; Fontify CHECK-FOO like CHECK-TYPE.
+(defvar slime-additional-font-lock-keywords
+ '(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\|without-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
+   ("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
+   ("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face)
+   ("(\\(assert-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face)))
+
+;;;; Specially fontify forms suppressed by a reader conditional.
+(defcustom slime-highlight-suppressed-forms t
+  "Display forms disabled by reader conditionals as comments."
+  :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
+  :group 'slime-mode)
+
+(define-slime-contrib slime-fontifying-fu
+  "Additional fontification tweaks:
+Fontify WITH-FOO, DO-FOO, DEFINE-FOO like standard macros.
+Fontify CHECK-FOO like CHECK-TYPE."
+  (:authors "Tobias C. Rittweiler <tcr@freebits.de>")
+  (:license "GPL")
+  (:on-load
+   (font-lock-add-keywords
+    'lisp-mode slime-additional-font-lock-keywords)
+   (when slime-highlight-suppressed-forms
+     (slime-activate-font-lock-magic)))
+  (:on-unload
+   ;; FIXME: remove `slime-search-suppressed-forms', and remove the
+   ;; extend-region hook.
+   (font-lock-remove-keywords
+    'lisp-mode slime-additional-font-lock-keywords)))
+
+(defface slime-reader-conditional-face
+    '((t (:inherit font-lock-comment-face)))
+  "Face for compiler notes while selected."
+  :group 'slime-mode-faces)
+
+(defvar slime-search-suppressed-forms-match-data (list nil nil))
+
+(defun slime-search-suppressed-forms-internal (limit)
+  (when (search-forward-regexp slime-reader-conditionals-regexp limit t)
+    (let ((start (match-beginning 0))   ; save match data
+          (state (slime-current-parser-state)))
+      (if (or (nth 3 state) (nth 4 state)) ; inside string or comment?
+          (slime-search-suppressed-forms-internal limit)
+        (let* ((char (char-before))
+               (expr (read (current-buffer)))
+               (val  (slime-eval-feature-expression expr)))
+          (when (<= (point) limit)
+            (if (or (and (eq char ?+) (not val))
+                    (and (eq char ?-) val))
+                ;; If `slime-extend-region-for-font-lock' did not
+                ;; fully extend the region, the assertion below may
+                ;; fail. This should only happen on XEmacs and older
+                ;; versions of GNU Emacs.
+                (ignore-errors
+                  (forward-sexp) (backward-sexp)
+                  ;; Try to suppress as far as possible.
+                  (slime-forward-sexp)
+                  (cl-assert (<= (point) limit))
+                  (let ((md (match-data nil slime-search-suppressed-forms-match-data)))
+                    (setf (cl-first md) start)
+                    (setf (cl-second md) (point))
+                    (set-match-data md)
+                    t))
+              (slime-search-suppressed-forms-internal limit))))))))
+
+(defun slime-search-suppressed-forms (limit)
+  "Find reader conditionalized forms where the test is false."
+  (when (and slime-highlight-suppressed-forms
+             (slime-connected-p))
+    (let ((result 'retry))
+      (while (and (eq result 'retry) (<= (point) limit))
+        (condition-case condition
+            (setq result (slime-search-suppressed-forms-internal limit))
+          (end-of-file                        ; e.g. #+(
+           (setq result nil))
+          ;; We found a reader conditional we couldn't process for
+          ;; some reason; however, there may still be other reader
+          ;; conditionals before `limit'.
+          (invalid-read-syntax                ; e.g. #+#.foo
+           (setq result 'retry))
+          (scan-error                         ; e.g. #+nil (foo ...
+           (setq result 'retry))
+          (slime-incorrect-feature-expression ; e.g. #+(not foo bar)
+           (setq result 'retry))
+          (slime-unknown-feature-expression   ; e.g. #+(foo)
+           (setq result 'retry))
+          (error
+           (setq result nil)
+           (slime-display-warning
+            (concat "Caught error during fontification while searching for forms\n"
+                    "that are suppressed by reader-conditionals. The error was: %S.")
+            condition))))
+      result)))
+
+
+(defun slime-search-directly-preceding-reader-conditional ()
+  "Search for a directly preceding reader conditional. Return its
+position, or nil."
+  ;;; We search for a preceding reader conditional. Then we check that
+  ;;; between the reader conditional and the point where we started is
+  ;;; no other intervening sexp, and we check that the reader
+  ;;; conditional is at the same nesting level.
+  (condition-case nil
+      (let* ((orig-pt (point))
+	     (reader-conditional-pt
+	      (search-backward-regexp slime-reader-conditionals-regexp
+				      ;; We restrict the search to the
+				      ;; beginning of the /previous/ defun.
+				      (save-excursion
+					(beginning-of-defun)
+					(point))
+				      t)))
+	(when reader-conditional-pt
+          (let* ((parser-state
+                  (parse-partial-sexp
+		   (progn (goto-char (+ reader-conditional-pt 2))
+			  (forward-sexp) ; skip feature expr.
+			  (point))
+		   orig-pt))
+                 (paren-depth  (car  parser-state))
+                 (last-sexp-pt (cl-caddr  parser-state)))
+            (if (and paren-depth
+		     (not (cl-plusp paren-depth)) ; no '(' in between?
+                     (not last-sexp-pt)) ; no complete sexp in between?
+                reader-conditional-pt
+              nil))))
+    (scan-error nil)))			; improper feature expression
+
+
+;;; We'll push this onto `font-lock-extend-region-functions'. In past,
+;;; we didn't do so which made our reader-conditional font-lock magic
+;;; pretty unreliable (it wouldn't highlight all suppressed forms, and
+;;; worked quite non-deterministic in general.)
+;;;
+;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs.
+;;;
+;;; We make sure that `font-lock-beg' and `font-lock-end' always point
+;;; to the beginning or end of a toplevel form. So we never miss a
+;;; reader-conditional, or point in mid of one.
+(defvar font-lock-beg) ; shoosh compiler
+(defvar font-lock-end)
+
+(defun slime-extend-region-for-font-lock ()
+  (when slime-highlight-suppressed-forms
+    (condition-case c
+        (let (changedp)
+          (cl-multiple-value-setq (changedp font-lock-beg font-lock-end)
+            (slime-compute-region-for-font-lock font-lock-beg font-lock-end))
+          changedp)
+      (error
+       (slime-display-warning
+        (concat "Caught error when trying to extend the region for fontification.\n"
+                "The error was: %S\n"
+                "Further: font-lock-beg=%d, font-lock-end=%d.")
+        c font-lock-beg font-lock-end)))))
+
+(defun slime-beginning-of-tlf ()
+  (let ((pos (syntax-ppss-toplevel-pos (slime-current-parser-state))))
+    (if pos (goto-char pos))))
+
+(defun slime-compute-region-for-font-lock (orig-beg orig-end)
+  (let ((beg orig-beg)
+        (end orig-end))
+    (goto-char beg)
+    (inline (slime-beginning-of-tlf))
+    (cl-assert (not (cl-plusp (nth 0 (slime-current-parser-state)))))
+    (setq beg (let ((pt (point)))
+                (cond ((> (- beg pt) 20000) beg)
+                      ((slime-search-directly-preceding-reader-conditional))
+                      (t pt))))
+    (goto-char end)
+    (while (search-backward-regexp slime-reader-conditionals-regexp beg t)
+      (setq end (max end (save-excursion
+                           (ignore-errors (slime-forward-reader-conditional))
+                           (point)))))
+    (cl-values (or (/= beg orig-beg) (/= end orig-end)) beg end)))
+
+
+(defun slime-activate-font-lock-magic ()
+  (if (featurep 'xemacs)
+      (let ((pattern `((slime-search-suppressed-forms
+                        (0 slime-reader-conditional-face t)))))
+        (dolist (sym '(lisp-font-lock-keywords
+                       lisp-font-lock-keywords-1
+                       lisp-font-lock-keywords-2))
+          (set sym (append (symbol-value sym) pattern))))
+      (font-lock-add-keywords
+       'lisp-mode
+       `((slime-search-suppressed-forms 0 ,''slime-reader-conditional-face t)))
+
+      (add-hook 'lisp-mode-hook
+                #'(lambda ()
+                    (add-hook 'font-lock-extend-region-functions
+                              'slime-extend-region-for-font-lock t t)))))
+
+(let ((byte-compile-warnings '()))
+  (mapc (lambda (sym)
+          (cond ((fboundp sym)
+                 (unless (byte-code-function-p (symbol-function sym))
+                   (byte-compile sym)))
+                (t (error "%S is not fbound" sym))))
+        '(slime-extend-region-for-font-lock
+          slime-compute-region-for-font-lock
+          slime-search-directly-preceding-reader-conditional
+          slime-search-suppressed-forms
+          slime-beginning-of-tlf)))
+
+(cl-defun slime-initialize-lisp-buffer-for-test-suite
+    (&key (font-lock-magic t) (autodoc t))
+  (let ((hook lisp-mode-hook))
+    (unwind-protect
+        (progn
+          (set (make-local-variable 'slime-highlight-suppressed-forms)
+               font-lock-magic)
+          (setq lisp-mode-hook nil)
+          (lisp-mode)
+          (slime-mode 1)
+          (when (boundp 'slime-autodoc-mode)
+            (if autodoc
+                (slime-autodoc-mode 1)
+              (slime-autodoc-mode -1))))
+      (setq lisp-mode-hook hook))))
+
+(provide 'slime-fontifying-fu)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fuzzy.el

@@ -0,0 +1,604 @@
+(require 'slime)
+(require 'slime-repl)
+(require 'slime-c-p-c)
+(require 'cl-lib)
+
+(define-slime-contrib slime-fuzzy
+  "Fuzzy symbol completion."
+  (:authors "Brian Downing <bdowning@lavos.net>"
+            "Tobias C. Rittweiler <tcr@freebits.de>"
+            "Attila Lendvai <attila.lendvai@gmail.com>")
+  (:license "GPL")
+  (:swank-dependencies swank-fuzzy)
+  (:on-load
+   (define-key slime-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol)
+   (when (featurep 'slime-repl)
+     (define-key slime-repl-mode-map "\C-c\M-i"
+       'slime-fuzzy-complete-symbol))))
+
+(defcustom slime-fuzzy-completion-in-place t
+  "When non-NIL the fuzzy symbol completion is done in place as
+opposed to moving the point to the completion buffer."
+  :group 'slime-mode
+  :type 'boolean)
+
+(defcustom slime-fuzzy-completion-limit 300
+  "Only return and present this many symbols from swank."
+  :group 'slime-mode
+  :type 'integer)
+
+(defcustom slime-fuzzy-completion-time-limit-in-msec 1500
+  "Limit the time spent (given in msec) in swank while gathering
+completions."
+  :group 'slime-mode
+  :type 'integer)
+
+(defcustom slime-when-complete-filename-expand nil
+  "Use comint-replace-by-expanded-filename instead of
+comint-filename-completion to complete file names"
+  :group 'slime-mode
+  :type 'boolean)
+
+
+(defvar slime-fuzzy-target-buffer nil
+  "The buffer that is the target of the completion activities.")
+(defvar slime-fuzzy-saved-window-configuration nil
+  "The saved window configuration before the fuzzy completion
+buffer popped up.")
+(defvar slime-fuzzy-start nil
+  "The beginning of the completion slot in the target buffer.
+This is a non-advancing marker.")
+(defvar slime-fuzzy-end nil
+  "The end of the completion slot in the target buffer.
+This is an advancing marker.")
+(defvar slime-fuzzy-original-text nil
+  "The original text that was in the completion slot in the
+target buffer.  This is what is put back if completion is
+aborted.")
+(defvar slime-fuzzy-text nil
+  "The text that is currently in the completion slot in the
+target buffer.  If this ever doesn't match, the target buffer has
+been modified and we abort without touching it.")
+(defvar slime-fuzzy-first nil
+  "The position of the first completion in the completions buffer.
+The descriptive text and headers are above this.")
+(defvar slime-fuzzy-last nil
+    "The position of the last completion in the completions buffer.
+If the time limit has exhausted during generation possible completion
+choices inside SWANK, an indication is printed below this.")
+(defvar slime-fuzzy-current-completion nil
+  "The current completion object.  If this is the same before and
+after point moves in the completions buffer, the text is not
+replaced in the target for efficiency.")
+(defvar slime-fuzzy-current-completion-overlay nil
+  "The overlay representing the current completion in the completion
+buffer. This is used to hightlight the text.")
+
+;;;;;;; slime-target-buffer-fuzzy-completions-mode
+;; NOTE: this mode has to be able to override key mappings in slime-mode
+
+(defvar slime-target-buffer-fuzzy-completions-map
+  (let ((map (make-sparse-keymap)))
+    (cl-labels ((def (keys command)
+                   (unless (listp keys)
+                     (setq keys (list keys)))
+                   (dolist (key keys)
+                     (define-key map key command))))
+      (def `([remap keyboard-quit]
+             ,(kbd "C-g"))
+           'slime-fuzzy-abort)
+      (def `([remap slime-fuzzy-indent-and-complete-symbol]
+             [remap slime-indent-and-complete-symbol]
+             ,(kbd "<tab>"))
+           'slime-fuzzy-select-or-update-completions)
+      (def `([remap previous-line]
+             ,(kbd "<up>"))
+           'slime-fuzzy-prev)
+      (def `([remap next-line]
+             ,(kbd "<down>"))
+           'slime-fuzzy-next)
+      (def `([remap isearch-forward]
+             ,(kbd "C-s"))
+           'slime-fuzzy-continue-isearch-in-fuzzy-buffer)
+      ;; some unconditional direct bindings
+      (def (list (kbd "<return>") (kbd "RET") (kbd "<SPC>") "(" ")" "[" "]")
+           'slime-fuzzy-select-and-process-event-in-target-buffer))
+    map)
+  "Keymap for slime-target-buffer-fuzzy-completions-mode.
+This will override the key bindings in the target buffer
+temporarily during completion.")
+
+;; Make sure slime-fuzzy-target-buffer-completions-mode's map is
+;; before everything else.
+(setf minor-mode-map-alist
+      (cl-stable-sort minor-mode-map-alist
+                      (lambda (a b)
+                        (eq a 'slime-fuzzy-target-buffer-completions-mode))
+                      :key #'car))
+
+(defun slime-fuzzy-continue-isearch-in-fuzzy-buffer ()
+  (interactive)
+  (select-window (get-buffer-window (slime-get-fuzzy-buffer)))
+  (call-interactively 'isearch-forward))
+
+(define-minor-mode slime-fuzzy-target-buffer-completions-mode
+  "This minor mode is intented to override key bindings during
+fuzzy completions in the target buffer. Most of the bindings will
+do an implicit select in the completion window and let the
+keypress be processed in the target buffer."
+  nil
+  nil
+  slime-target-buffer-fuzzy-completions-map)
+
+(add-to-list 'minor-mode-alist
+             '(slime-fuzzy-target-buffer-completions-mode
+               " Fuzzy Target Buffer Completions"))
+
+(defvar slime-fuzzy-completions-map
+  (let ((map (make-sparse-keymap)))
+    (cl-labels ((def (keys command)
+                     (unless (listp keys)
+                       (setq keys (list keys)))
+                     (dolist (key keys)
+                       (define-key map key command))))
+      (def `([remap keyboard-quit]
+             "q"
+             ,(kbd "C-g"))
+           'slime-fuzzy-abort)
+      (def `([remap previous-line]
+             "p"
+             "\M-p"
+             ,(kbd "<up>"))
+           'slime-fuzzy-prev)
+      (def `([remap next-line]
+             "n"
+             "\M-n"
+             ,(kbd "<down>"))
+           'slime-fuzzy-next)
+      (def "\d" 'scroll-down)
+      (def `([remap slime-fuzzy-indent-and-complete-symbol]
+             [remap slime-indent-and-complete-symbol]
+             ,(kbd "<tab>"))
+           'slime-fuzzy-select)
+      (def (kbd "<mouse-2>") 'slime-fuzzy-select/mouse)
+      (def `(,(kbd "RET")
+             ,(kbd "<SPC>"))
+           'slime-fuzzy-select))
+    map)
+  "Keymap for slime-fuzzy-completions-mode when in the completion buffer.")
+
+(define-derived-mode slime-fuzzy-completions-mode
+  fundamental-mode "Fuzzy Completions"
+  "Major mode for presenting fuzzy completion results.
+
+When you run `slime-fuzzy-complete-symbol', the symbol token at
+point is completed using the Fuzzy Completion algorithm; this
+means that the token is taken as a sequence of characters and all
+the various possibilities that this sequence could meaningfully
+represent are offered as selectable choices, sorted by how well
+they deem to be a match for the token. (For instance, the first
+choice of completing on \"mvb\" would be \"multiple-value-bind\".)
+
+Therefore, a new buffer (*Fuzzy Completions*) will pop up that
+contains the different completion choices. Simultaneously, a
+special minor-mode will be temporarily enabled in the original
+buffer where you initiated fuzzy completion (also called the
+``target buffer'') in order to navigate through the *Fuzzy
+Completions* buffer without leaving.
+
+With focus in *Fuzzy Completions*:
+  Type `n' and `p' (`UP', `DOWN') to navigate between completions.
+  Type `RET' or `TAB' to select the completion near point.
+  Type `q' to abort.
+
+With focus in the target buffer:
+  Type `UP' and `DOWN' to navigate between completions.
+  Type a character that does not constitute a symbol name
+  to insert the current choice and then that character (`(', `)',
+  `SPACE', `RET'.) Use `TAB' to simply insert the current choice.
+  Use C-g to abort.
+
+Alternatively, you can click <mouse-2> on a completion to select it.
+
+
+Complete listing of keybindings within the target buffer:
+
+\\<slime-target-buffer-fuzzy-completions-map>\
+\\{slime-target-buffer-fuzzy-completions-map}
+
+Complete listing of keybindings with *Fuzzy Completions*:
+
+\\<slime-fuzzy-completions-map>\
+\\{slime-fuzzy-completions-map}"
+  (use-local-map slime-fuzzy-completions-map)
+  (set (make-local-variable 'slime-fuzzy-current-completion-overlay)
+       (make-overlay (point) (point) nil t nil)))
+
+(defun slime-fuzzy-completions (prefix &optional default-package)
+  "Get the list of sorted completion objects from completing
+`prefix' in `package' from the connected Lisp."
+  (let ((prefix (cl-etypecase prefix
+                  (symbol (symbol-name prefix))
+                  (string prefix))))
+    (slime-eval `(swank:fuzzy-completions ,prefix
+                                          ,(or default-package
+                                               (slime-current-package))
+                  :limit ,slime-fuzzy-completion-limit
+                  :time-limit-in-msec
+                  ,slime-fuzzy-completion-time-limit-in-msec))))
+
+(defun slime-fuzzy-selected (prefix completion)
+  "Tell the connected Lisp that the user selected completion
+`completion' as the completion for `prefix'."
+  (let ((no-properties (copy-sequence prefix)))
+    (set-text-properties 0 (length no-properties) nil no-properties)
+    (slime-eval `(swank:fuzzy-completion-selected ,no-properties
+                                                  ',completion))))
+
+(defun slime-fuzzy-indent-and-complete-symbol ()
+  "Indent the current line and perform fuzzy symbol completion.  First
+indent the line. If indenting doesn't move point, complete the
+symbol. If there's no symbol at the point, show the arglist for the
+most recently enclosed macro or function."
+  (interactive)
+  (let ((pos (point)))
+    (unless (get-text-property (line-beginning-position) 'slime-repl-prompt)
+      (lisp-indent-line))
+    (when (= pos (point))
+      (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t))
+             (slime-fuzzy-complete-symbol))
+            ((memq (char-before) '(?\t ?\ ))
+             (slime-echo-arglist))))))
+
+(cl-defun slime-fuzzy-complete-symbol ()
+  "Fuzzily completes the abbreviation at point into a symbol."
+  (interactive)
+  (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t))
+    (cl-return-from slime-fuzzy-complete-symbol
+      ;; don't add space after completion
+      (let ((comint-completion-addsuffix '("/" . "")))
+        (if slime-when-complete-filename-expand
+            (comint-replace-by-expanded-filename)
+          ;; FIXME: use `comint-filename-completion' when dropping emacs23
+          (funcall (if (>= emacs-major-version 24)
+                       'comint-filename-completion
+                     'comint-dynamic-complete-as-filename))))))
+  (let* ((end (move-marker (make-marker) (slime-symbol-end-pos)))
+         (beg (move-marker (make-marker) (slime-symbol-start-pos)))
+         (prefix (buffer-substring-no-properties beg end)))
+    (cl-destructuring-bind (completion-set interrupted-p)
+        (slime-fuzzy-completions prefix)
+      (if (null completion-set)
+          (progn (slime-minibuffer-respecting-message
+                  "Can't find completion for \"%s\"" prefix)
+                 (ding)
+                 (slime-fuzzy-done))
+          (goto-char end)
+          (cond ((slime-length= completion-set 1)
+                 ;; insert completed string
+                 (insert-and-inherit (caar completion-set))
+                 (delete-region beg end)
+                 (goto-char (+ beg (length (caar completion-set))))
+                 (slime-minibuffer-respecting-message "Sole completion")
+                 (slime-fuzzy-done))
+                ;; Incomplete
+                (t
+                 (slime-fuzzy-choices-buffer completion-set interrupted-p
+                                             beg end)
+                 (slime-minibuffer-respecting-message
+                  "Complete but not unique")))))))
+
+
+(defun slime-get-fuzzy-buffer ()
+  (get-buffer-create "*Fuzzy Completions*"))
+
+(defvar slime-fuzzy-explanation
+  "For help on how the use this buffer, see `slime-fuzzy-completions-mode'.
+
+Flags: boundp fboundp generic-function class macro special-operator package
+\n"
+  "The explanation that gets inserted at the beginning of the
+*Fuzzy Completions* buffer.")
+
+(defun slime-fuzzy-insert-completion-choice (completion max-length)
+  "Inserts the completion object `completion' as a formatted
+completion choice into the current buffer, and mark it with the
+proper text properties."
+  (cl-destructuring-bind (symbol-name score chunks classification-string)
+      completion
+    (let ((start (point))
+          (end))
+      (insert symbol-name)
+      (setq end (point))
+      (dolist (chunk chunks)
+        (put-text-property (+ start (cl-first chunk))
+                           (+ start (cl-first chunk)
+                              (length (cl-second chunk)))
+                           'face 'bold))
+      (put-text-property start (point) 'mouse-face 'highlight)
+      (dotimes (i (- max-length (- end start)))
+        (insert " "))
+      (insert (format " %s %s\n"
+                      classification-string
+                      score))
+      (put-text-property start (point) 'completion completion))))
+
+(defun slime-fuzzy-insert (text)
+  "Inserts `text' into the target buffer in the completion slot.
+If the buffer has been modified in the meantime, abort the
+completion process.  Otherwise, update all completion variables
+so that the new text is present."
+  (with-current-buffer slime-fuzzy-target-buffer
+    (cond
+     ((not (string-equal slime-fuzzy-text
+                         (buffer-substring slime-fuzzy-start
+                                           slime-fuzzy-end)))
+      (slime-fuzzy-done)
+      (beep)
+      (message "Target buffer has been modified!"))
+     (t
+      (goto-char slime-fuzzy-start)
+      (delete-region slime-fuzzy-start slime-fuzzy-end)
+      (insert-and-inherit text)
+      (setq slime-fuzzy-text text)
+      (goto-char slime-fuzzy-end)))))
+
+(defun slime-minibuffer-p (buffer)
+  (if (featurep 'xemacs)
+      (eq buffer (window-buffer (minibuffer-window)))
+      (minibufferp buffer)))
+
+(defun slime-fuzzy-choices-buffer (completions interrupted-p start end)
+  "Creates (if neccessary), populates, and pops up the *Fuzzy
+Completions* buffer with the completions from `completions' and
+the completion slot in the current buffer bounded by `start' and
+`end'.  This saves the window configuration before popping the
+buffer so that it can possibly be restored when the user is
+done."
+  (let ((new-completion-buffer (not slime-fuzzy-target-buffer))
+        (connection (slime-connection)))
+    (when new-completion-buffer
+      (setq slime-fuzzy-saved-window-configuration
+            (current-window-configuration)))
+    (slime-fuzzy-enable-target-buffer-completions-mode)
+    (setq slime-fuzzy-target-buffer (current-buffer))
+    (setq slime-fuzzy-start (move-marker (make-marker) start))
+    (setq slime-fuzzy-end (move-marker (make-marker) end))
+    (set-marker-insertion-type slime-fuzzy-end t)
+    (setq slime-fuzzy-original-text (buffer-substring start end))
+    (setq slime-fuzzy-text slime-fuzzy-original-text)
+    (slime-fuzzy-fill-completions-buffer completions interrupted-p)
+    (pop-to-buffer (slime-get-fuzzy-buffer))
+    (slime-fuzzy-next)
+    (setq slime-buffer-connection connection)
+    (when new-completion-buffer
+      ;; Hook to nullify window-config restoration if the user changes
+      ;; the window configuration himself.
+      (when (boundp 'window-configuration-change-hook)
+        (add-hook 'window-configuration-change-hook
+                  'slime-fuzzy-window-configuration-change))
+      (add-hook 'kill-buffer-hook 'slime-fuzzy-abort 'append t)
+      (set (make-local-variable 'cursor-type) nil)
+      (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc
+    (when slime-fuzzy-completion-in-place
+      ;; switch back to the original buffer
+      (if (slime-minibuffer-p slime-fuzzy-target-buffer)
+          (select-window (minibuffer-window))
+          (switch-to-buffer-other-window slime-fuzzy-target-buffer)))))
+
+(defun slime-fuzzy-fill-completions-buffer (completions interrupted-p)
+  "Erases and fills the completion buffer with the given completions."
+  (with-current-buffer (slime-get-fuzzy-buffer)
+    (setq buffer-read-only nil)
+    (erase-buffer)
+    (slime-fuzzy-completions-mode)
+    (insert slime-fuzzy-explanation)
+    (let ((max-length 12))
+      (dolist (completion completions)
+        (setf max-length (max max-length (length (cl-first completion)))))
+
+      (insert "Completion:")
+      (dotimes (i (- max-length 10)) (insert " "))
+      ;;     Flags:   Score:
+      ;; ... -------  --------
+      ;;     bfgctmsp
+      (let* ((example-classification-string (cl-fourth (cl-first completions)))
+             (classification-length (length example-classification-string))
+             (spaces (- classification-length (length "Flags:"))))
+        (insert "Flags:")
+        (dotimes (i spaces) (insert " "))
+        (insert " Score:\n")
+        (dotimes (i max-length) (insert "-"))
+        (insert " ")
+        (dotimes (i classification-length) (insert "-"))
+        (insert " --------\n")
+        (setq slime-fuzzy-first (point)))
+
+      (dolist (completion completions)
+        (setq slime-fuzzy-last (point)) ; will eventually become the last entry
+        (slime-fuzzy-insert-completion-choice completion max-length))
+
+      (when interrupted-p
+        (insert "...\n")
+        (insert "[Interrupted: time limit exhausted]"))
+
+      (setq buffer-read-only t))
+    (setq slime-fuzzy-current-completion
+          (caar completions))
+    (goto-char 0)))
+
+(defun slime-fuzzy-enable-target-buffer-completions-mode ()
+  "Store the target buffer's local map, so that we can restore it."
+  (unless slime-fuzzy-target-buffer-completions-mode
+;    (slime-log-event "Enabling target buffer completions mode")
+    (slime-fuzzy-target-buffer-completions-mode 1)))
+
+(defun slime-fuzzy-disable-target-buffer-completions-mode ()
+  "Restores the target buffer's local map when completion is finished."
+  (when slime-fuzzy-target-buffer-completions-mode
+;    (slime-log-event "Disabling target buffer completions mode")
+    (slime-fuzzy-target-buffer-completions-mode 0)))
+
+(defun slime-fuzzy-insert-from-point ()
+  "Inserts the completion that is under point in the completions
+buffer into the target buffer.  If the completion in question had
+already been inserted, it does nothing."
+  (with-current-buffer (slime-get-fuzzy-buffer)
+    (let ((current-completion (get-text-property (point) 'completion)))
+      (when (and current-completion
+                 (not (eq slime-fuzzy-current-completion
+                          current-completion)))
+        (slime-fuzzy-insert
+         (cl-first (get-text-property (point) 'completion)))
+        (setq slime-fuzzy-current-completion
+              current-completion)))))
+
+(defun slime-fuzzy-post-command-hook ()
+  "The post-command-hook for the *Fuzzy Completions* buffer.
+This makes sure the completion slot in the target buffer matches
+the completion that point is on in the completions buffer."
+  (condition-case err
+      (when slime-fuzzy-target-buffer
+        (slime-fuzzy-insert-from-point))
+    (error
+     ;; Because this is called on the post-command-hook, we mustn't let
+     ;; errors propagate.
+     (message "Error in slime-fuzzy-post-command-hook: %S" err))))
+
+(defun slime-fuzzy-next ()
+  "Moves point directly to the next completion in the completions
+buffer."
+  (interactive)
+  (with-current-buffer (slime-get-fuzzy-buffer)
+    (let ((point (next-single-char-property-change
+                  (point) 'completion nil slime-fuzzy-last)))
+      (set-window-point (get-buffer-window (current-buffer)) point)
+      (goto-char point))
+    (slime-fuzzy-highlight-current-completion)))
+
+(defun slime-fuzzy-prev ()
+  "Moves point directly to the previous completion in the
+completions buffer."
+  (interactive)
+  (with-current-buffer (slime-get-fuzzy-buffer)
+    (let ((point (previous-single-char-property-change
+                  (point)
+                  'completion nil slime-fuzzy-first)))
+      (set-window-point (get-buffer-window (current-buffer)) point)
+      (goto-char point))
+    (slime-fuzzy-highlight-current-completion)))
+
+(defun slime-fuzzy-highlight-current-completion ()
+  "Highlights the current completion,
+so that the user can see it on the screen."
+  (let ((pos (point)))
+    (when (overlayp slime-fuzzy-current-completion-overlay)
+      (move-overlay slime-fuzzy-current-completion-overlay
+                    (point) (1- (search-forward " ")))
+      (overlay-put slime-fuzzy-current-completion-overlay
+                   'face 'secondary-selection))
+    (goto-char pos)))
+
+(defun slime-fuzzy-abort ()
+  "Aborts the completion process, setting the completions slot in
+the target buffer back to its original contents."
+  (interactive)
+  (when slime-fuzzy-target-buffer
+    (slime-fuzzy-done)))
+
+(defun slime-fuzzy-select ()
+  "Selects the current completion, making sure that it is inserted
+into the target buffer.  This tells the connected Lisp what completion
+was selected."
+  (interactive)
+  (when slime-fuzzy-target-buffer
+    (with-current-buffer (slime-get-fuzzy-buffer)
+      (let ((completion (get-text-property (point) 'completion)))
+        (when completion
+          (slime-fuzzy-insert (cl-first completion))
+          (slime-fuzzy-selected slime-fuzzy-original-text
+                                completion)
+          (slime-fuzzy-done))))))
+
+(defun slime-fuzzy-select-or-update-completions ()
+  "If there were no changes since the last time fuzzy completion was started
+this function will select the current completion.
+Otherwise refreshes the completion list based on the changes made."
+  (interactive)
+;  (slime-log-event "Selecting or updating completions")
+  (if (string-equal slime-fuzzy-original-text
+                    (buffer-substring slime-fuzzy-start
+                                      slime-fuzzy-end))
+      (slime-fuzzy-select)
+      (slime-fuzzy-complete-symbol)))
+
+(defun slime-fuzzy-process-event-in-completions-buffer ()
+  "Simply processes the event in the target buffer"
+  (interactive)
+  (with-current-buffer (slime-get-fuzzy-buffer)
+    (push last-input-event unread-command-events)))
+
+(defun slime-fuzzy-select-and-process-event-in-target-buffer ()
+ "Selects the current completion, making sure that it is inserted
+into the target buffer and processes the event in the target buffer."
+ (interactive)
+; (slime-log-event "Selecting and processing event in target buffer")
+ (when slime-fuzzy-target-buffer
+   (let ((buff slime-fuzzy-target-buffer))
+     (slime-fuzzy-select)
+     (with-current-buffer buff
+       (slime-fuzzy-disable-target-buffer-completions-mode)
+       (push last-input-event unread-command-events)))))
+
+(defun slime-fuzzy-select/mouse (event)
+  "Handle a mouse-2 click on a completion choice as if point were
+on the completion choice and the slime-fuzzy-select command was
+run."
+  (interactive "e")
+  (with-current-buffer (window-buffer (posn-window (event-end event)))
+    (save-excursion
+      (goto-char (posn-point (event-end event)))
+      (when (get-text-property (point) 'mouse-face)
+        (slime-fuzzy-insert-from-point)
+        (slime-fuzzy-select)))))
+
+(defun slime-fuzzy-done ()
+  "Cleans up after the completion process.  This removes all hooks,
+and attempts to restore the window configuration.  If this fails,
+it just burys the completions buffer and leaves the window
+configuration alone."
+  (when slime-fuzzy-target-buffer
+    (set-buffer slime-fuzzy-target-buffer)
+    (slime-fuzzy-disable-target-buffer-completions-mode)
+    (if (slime-fuzzy-maybe-restore-window-configuration)
+        (bury-buffer (slime-get-fuzzy-buffer))
+        ;; We couldn't restore the windows, so just bury the fuzzy
+        ;; completions buffer and let something else fill it in.
+        (pop-to-buffer (slime-get-fuzzy-buffer))
+        (bury-buffer))
+    (if (slime-minibuffer-p slime-fuzzy-target-buffer)
+        (select-window (minibuffer-window))
+        (pop-to-buffer slime-fuzzy-target-buffer))
+    (goto-char slime-fuzzy-end)
+    (setq slime-fuzzy-target-buffer nil)
+    (remove-hook 'window-configuration-change-hook
+                 'slime-fuzzy-window-configuration-change)))
+
+(defun slime-fuzzy-maybe-restore-window-configuration ()
+  "Restores the saved window configuration if it has not been
+nullified."
+  (when (boundp 'window-configuration-change-hook)
+    (remove-hook 'window-configuration-change-hook
+                 'slime-fuzzy-window-configuration-change))
+  (if (not slime-fuzzy-saved-window-configuration)
+      nil
+    (set-window-configuration slime-fuzzy-saved-window-configuration)
+    (setq slime-fuzzy-saved-window-configuration nil)
+    t))
+
+(defun slime-fuzzy-window-configuration-change ()
+  "Called on window-configuration-change-hook.  Since the window
+configuration was changed, we nullify our saved configuration."
+  (setq slime-fuzzy-saved-window-configuration nil))
+
+(provide 'slime-fuzzy)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-highlight-edits.el

@@ -0,0 +1,81 @@
+(require 'slime)
+(require 'slime-parse)
+
+(define-slime-contrib slime-highlight-edits
+  "Highlight edited, i.e. not yet compiled, code."
+  (:authors "William Bland <doctorbill.news@gmail.com>")
+  (:license "GPL")
+  (:on-load   (add-hook 'slime-mode-hook 'slime-activate-highlight-edits))
+  (:on-unload (remove-hook 'slime-mode-hook 'slime-activate-highlight-edits)))
+
+(defun slime-activate-highlight-edits ()
+ (slime-highlight-edits-mode 1))
+
+(defface slime-highlight-edits-face
+    `((((class color) (background light))
+       (:background "lightgray"))
+      (((class color) (background dark))
+       (:background "dimgray"))
+      (t (:background "yellow")))
+  "Face for displaying edit but not compiled code."
+  :group 'slime-mode-faces)
+
+(define-minor-mode slime-highlight-edits-mode 
+  "Minor mode to highlight not-yet-compiled code." nil)
+
+(add-hook 'slime-highlight-edits-mode-on-hook
+          'slime-highlight-edits-init-buffer)
+
+(add-hook 'slime-highlight-edits-mode-off-hook
+          'slime-highlight-edits-reset-buffer)
+
+(defun slime-highlight-edits-init-buffer ()
+  (make-local-variable 'after-change-functions)
+  (add-to-list 'after-change-functions 
+               'slime-highlight-edits)
+  (add-to-list 'slime-before-compile-functions
+               'slime-highlight-edits-compile-hook))
+
+(defun slime-highlight-edits-reset-buffer ()
+  (setq after-change-functions  
+        (remove 'slime-highlight-edits after-change-functions))
+  (slime-remove-edits (point-min) (point-max)))
+
+;; FIXME: what's the LEN arg for?
+(defun slime-highlight-edits (beg end &optional len) 
+  (save-match-data
+    (when (and (slime-connected-p)
+               (not (slime-inside-comment-p))
+               (not (slime-only-whitespace-p beg end)))
+      (let ((overlay (make-overlay beg end)))
+        (overlay-put overlay 'face 'slime-highlight-edits-face)
+        (overlay-put overlay 'slime-edit t)))))
+
+(defun slime-remove-edits (start end)
+  "Delete the existing Slime edit hilights in the current buffer."
+  (save-excursion
+    (goto-char start)
+    (while (< (point) end)
+      (dolist (o (overlays-at (point)))
+        (when (overlay-get o 'slime-edit)
+          (delete-overlay o)))
+      (goto-char (next-overlay-change (point))))))
+
+(defun slime-highlight-edits-compile-hook (start end)
+  (when slime-highlight-edits-mode
+    (let ((start (save-excursion (goto-char start) 
+				 (skip-chars-backward " \t\n\r")
+				 (point)))
+	  (end (save-excursion (goto-char end) 
+			       (skip-chars-forward " \t\n\r")
+			       (point))))
+      (slime-remove-edits start end))))
+
+(defun slime-only-whitespace-p (beg end)
+  "Contains the region from BEG to END only whitespace?"
+  (save-excursion
+    (goto-char beg)
+    (skip-chars-forward " \n\t\r" end)
+    (<= end (point))))
+
+(provide 'slime-highlight-edits)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-hyperdoc.el

@@ -0,0 +1,48 @@
+(require 'slime)
+(require 'url-http)
+(require 'browse-url)
+(eval-when-compile (require 'cl)) ; lexical-let
+
+(defvar slime-old-documentation-lookup-function 
+  slime-documentation-lookup-function)
+
+(define-slime-contrib slime-hyperdoc
+  "Extensible C-c C-d h."
+  (:authors "Tobias C Rittweiler <tcr@freebits.de>")
+  (:license "GPL")
+  (:swank-dependencies swank-hyperdoc)
+  (:on-load
+   (setq slime-documentation-lookup-function 'slime-hyperdoc-lookup))
+  (:on-unload
+   (setq slime-documentation-lookup-function 
+         slime-old-documentation-lookup-function)))
+
+;;; TODO: `url-http-file-exists-p' is slow, make it optional behaviour.
+
+(defun slime-hyperdoc-lookup-rpc (symbol-name)
+  (slime-eval-async `(swank:hyperdoc ,symbol-name)
+    (lexical-let ((symbol-name symbol-name))
+      #'(lambda (result)
+          (slime-log-event result)
+          (cl-loop with foundp = nil
+                   for (doc-type . url) in result do
+                   (when (and url (stringp url)
+                              (let ((url-show-status nil))
+                                (url-http-file-exists-p url)))
+                     (message "Visiting documentation for %s `%s'..."
+                              (substring (symbol-name doc-type) 1)
+                              symbol-name)
+                     (browse-url url)
+                     (setq foundp t))
+                   finally
+                   (unless foundp
+                     (error "Could not find documentation for `%s'." 
+                            symbol-name)))))))
+
+(defun slime-hyperdoc-lookup (symbol-name)
+  (interactive (list (slime-read-symbol-name "Symbol: ")))
+  (if (memq :hyperdoc (slime-lisp-features))
+      (slime-hyperdoc-lookup-rpc symbol-name)
+      (slime-hyperspec-lookup symbol-name)))
+
+(provide 'slime-hyperdoc)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-indentation.el

@@ -0,0 +1,31 @@
+(require 'slime)
+(require 'slime-cl-indent)
+(require 'cl-lib)
+
+(define-slime-contrib slime-indentation
+  "Contrib interfacing `slime-cl-indent' and SLIME."
+  (:swank-dependencies swank-indentation)
+  (:on-load
+   (setq common-lisp-current-package-function 'slime-current-package)))
+
+(defun slime-update-system-indentation (symbol indent packages)
+  (let ((list (gethash symbol common-lisp-system-indentation))
+        (ok nil))
+    (if (not list)
+        (puthash symbol (list (cons indent packages))
+                 common-lisp-system-indentation)
+      (dolist (spec list)
+        (cond ((equal (car spec) indent)
+               (dolist (p packages)
+                 (unless (member p (cdr spec))
+                   (push p (cdr spec))))
+               (setf ok t))
+              (t
+               (setf (cdr spec)
+                     (cl-set-difference (cdr spec) packages :test 'equal)))))
+      (unless ok
+        (puthash symbol (cons (cons indent packages)
+                              list)
+                 common-lisp-system-indentation)))))
+
+(provide 'slime-indentation)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-listener-hooks.el

@@ -0,0 +1,11 @@
+(require 'slime)
+(require 'cl-lib)
+
+(define-slime-contrib slime-listener-hooks
+  "Enable slime integration in an application'w event loop"
+  (:authors "Alan Ruttenberg  <alanr-l@mumble.net>, R. Mattes <rm@seid-online.de>")
+  (:license "GPL")
+  (:slime-dependencies slime-repl)
+  (:swank-dependencies swank-listener-hooks))
+
+(provide 'slime-listener-hooks)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-macrostep.el

@@ -0,0 +1,129 @@
+;;; slime-macrostep.el -- fancy macro-expansion via macrostep.el
+
+;; Authors: Luís Oliveira <luismbo@gmail.com>
+;;          Jon Oddie <j.j.oddie@gmail.com
+;;
+;; License: GNU GPL (same license as Emacs)
+
+;;; Description:
+
+;; Fancier in-place macro-expansion using macrostep.el (originally
+;; written for Emacs Lisp).  To use, position point before the
+;; open-paren of the macro call in a SLIME source or REPL buffer, and
+;; type `C-c M-e' or `M-x macrostep-expand'.  The pretty-printed
+;; result of `macroexpand-1' will be inserted inline in the current
+;; buffer, which is temporarily read-only while macro expansions are
+;; visible.  If the expansion is itself a macro call, expansion can be
+;; continued by typing `e'.  Expansions are collapsed to their
+;; original macro forms by typing `c' or `q'.  Other macro- and
+;; compiler-macro calls in the expansion will be font-locked
+;; differently, and point can be moved there quickly by typing `n' or
+;; `p'.  For more details, see the documentation of
+;; `macrostep-expand'.
+
+;;; Code:
+
+(require 'slime)
+(eval-and-compile
+  (require 'macrostep nil t)
+  ;; Use bundled version if not separately installed
+  (require 'macrostep "../lib/macrostep"))
+(eval-when-compile (require 'cl-lib))
+
+(defvar slime-repl-mode-hook)
+(defvar slime-repl-mode-map)
+
+(define-slime-contrib slime-macrostep
+  "Interactive macro expansion via macrostep.el."
+  (:authors "Luís Oliveira       <luismbo@gmail.com>"
+            "Jon Oddie           <j.j.oddie@gmail.com>")
+  (:license "GPL")
+  (:swank-dependencies swank-macrostep)
+  (:on-load
+   (easy-menu-add-item slime-mode-map '(menu-bar SLIME Debugging)
+                       ["Macro stepper..." macrostep-expand (slime-connected-p)]
+                       "Create Trace Buffer")
+   (add-hook 'slime-mode-hook #'macrostep-slime-mode-hook)
+   (define-key slime-mode-map (kbd "C-c M-e") #'macrostep-expand)
+   (eval-after-load 'slime-repl
+     '(progn
+       (add-hook 'slime-repl-mode-hook #'macrostep-slime-mode-hook)
+       (define-key slime-repl-mode-map (kbd "C-c M-e") #'macrostep-expand)))))
+
+(defun macrostep-slime-mode-hook ()
+  (setq macrostep-sexp-at-point-function #'macrostep-slime-sexp-at-point)
+  (setq macrostep-environment-at-point-function #'macrostep-slime-context)
+  (setq macrostep-expand-1-function #'macrostep-slime-expand-1)
+  (setq macrostep-print-function #'macrostep-slime-insert)
+  (setq macrostep-macro-form-p-function #'macrostep-slime-macro-form-p))
+
+(defun macrostep-slime-sexp-at-point (&rest _ignore)
+  (slime-sexp-at-point))
+
+(defun macrostep-slime-context ()
+  (let (defun-start defun-end)
+    (save-excursion
+      (while
+          (condition-case nil
+              (progn (backward-up-list) t)
+            (scan-error nil)))
+      (setq defun-start (point))
+      (setq defun-end (scan-sexps (point) 1)))
+    (list (buffer-substring-no-properties
+           defun-start (point))
+          (buffer-substring-no-properties
+           (scan-sexps (point) 1) defun-end))))
+
+(defun macrostep-slime-expand-1 (string context)
+  (slime-dcase
+      (slime-eval
+       `(swank-macrostep:macrostep-expand-1
+         ,string ,macrostep-expand-compiler-macros ',context))
+    ((:error error-message)
+     (error "%s" error-message))
+    ((:ok expansion positions)
+     (list expansion positions))))
+
+(defun macrostep-slime-insert (result _ignore)
+  "Insert RESULT at point, indenting to match the current column."
+  (cl-destructuring-bind (expansion positions) result
+    (let ((start (point))
+          (column-offset (current-column)))
+      (insert expansion)
+      (macrostep-slime--propertize-macros start positions)
+      (indent-rigidly start (point) column-offset))))
+
+(defun macrostep-slime--propertize-macros (start-offset positions)
+  "Put text properties on macro forms."
+  (dolist (position positions)
+    (cl-destructuring-bind (operator type start)
+        position
+      (let ((open-paren-position
+              (+ start-offset start)))
+        (put-text-property open-paren-position
+                           (1+ open-paren-position)
+                           'macrostep-macro-start
+                           t)
+        ;; this assumes that the operator starts right next to the
+        ;; opening parenthesis. We could probably be more robust.
+        (let ((op-start (1+ open-paren-position)))
+          (put-text-property op-start
+                             (+ op-start (length operator))
+                             'font-lock-face
+                             (if (eq type :macro)
+                                 'macrostep-macro-face
+                                 'macrostep-compiler-macro-face)))))))
+
+(defun macrostep-slime-macro-form-p (string context)
+  (slime-dcase
+      (slime-eval
+       `(swank-macrostep:macro-form-p
+         ,string ,macrostep-expand-compiler-macros ',context))
+    ((:error error-message)
+     (error "%s" error-message))
+    ((:ok result)
+     result)))
+
+
+
+(provide 'slime-macrostep)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-mdot-fu.el

@@ -0,0 +1,31 @@
+(require 'slime)
+(require 'cl-lib)
+
+(define-slime-contrib slime-mdot-fu
+  "Making M-. work on local functions."
+  (:authors "Tobias C. Rittweiler <tcr@freebits.de>")
+  (:license "GPL")
+  (:slime-dependencies slime-enclosing-context)
+  (:on-load
+   (add-hook 'slime-edit-definition-hooks 'slime-edit-local-definition))
+  (:on-unload
+   (remove-hook 'slime-edit-definition-hooks 'slime-edit-local-definition)))
+
+
+(defun slime-edit-local-definition (name &optional where)
+  "Like `slime-edit-definition', but tries to find the definition
+in a local function binding near point."
+  (interactive (list (slime-read-symbol-name "Name: ")))
+  (cl-multiple-value-bind (binding-name point)
+      (cl-multiple-value-call #'cl-some #'(lambda (binding-name point)
+                                            (when (cl-equalp binding-name name)
+                                              (cl-values binding-name point)))
+                              (slime-enclosing-bound-names))
+    (when (and binding-name point)
+      (slime-edit-definition-cont
+       `((,binding-name
+	  ,(make-slime-buffer-location (buffer-name (current-buffer)) point)))
+       name
+       where))))
+
+(provide 'slime-mdot-fu)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-media.el

@@ -0,0 +1,46 @@
+(eval-and-compile
+  (require 'slime))
+
+(define-slime-contrib slime-media
+  "Display things other than text in SLIME buffers"
+  (:authors "Christophe Rhodes <csr21@cantab.net>")
+  (:license "GPL")
+  (:slime-dependencies slime-repl)
+  (:swank-dependencies swank-media)
+  (:on-load
+   (add-hook 'slime-event-hooks 'slime-dispatch-media-event)))
+
+(defun slime-media-decode-image (image)
+  (mapcar (lambda (image)
+	    (if (plist-get image :data)
+		(plist-put image :data (base64-decode-string (plist-get image :data)))
+	      image))
+	  image))
+
+(defun slime-dispatch-media-event (event)
+  (slime-dcase event
+    ((:write-image image string)
+     (let ((img (or (find-image (slime-media-decode-image image))
+                    (create-image image))))
+       (slime-media-insert-image img string))
+     t)
+    ((:popup-buffer bufname string mode)
+     (slime-with-popup-buffer (bufname :connection t :package t)
+       (when mode (funcall mode))
+       (princ string)
+       (goto-char (point-min)))
+     t)
+    (t nil)))
+
+(defun slime-media-insert-image (image string &optional bol)
+  (with-current-buffer (slime-output-buffer)
+    (let ((marker (slime-repl-output-target-marker :repl-result)))
+      (goto-char marker)
+      (slime-propertize-region `(face slime-repl-result-face
+                                      rear-nonsticky (face))
+        (insert-image image string))
+      ;; Move the input-start marker after the REPL result.
+      (set-marker marker (point)))
+    (slime-repl-show-maximum-output)))
+
+(provide 'slime-media)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-mrepl.el

@@ -0,0 +1,150 @@
+;; An experimental implementation of multiple REPLs multiplexed over a
+;; single Slime socket.  M-x slime-new-mrepl creates a new REPL buffer.
+;;
+(require 'slime)
+(require 'inferior-slime) ; inferior-slime-indent-lime
+(require 'cl-lib)
+
+(define-slime-contrib slime-mrepl
+  "Multiple REPLs."
+  (:authors "Helmut Eller <heller@common-lisp.net>")
+  (:license "GPL")
+  (:swank-dependencies swank-mrepl))
+
+(require 'comint)
+
+(defvar slime-mrepl-remote-channel nil)
+(defvar slime-mrepl-expect-sexp nil)
+
+(define-derived-mode slime-mrepl-mode comint-mode "mrepl"
+  ;; idea lifted from ielm
+  (unless (get-buffer-process (current-buffer))
+    (let* ((process-connection-type nil)
+	   (proc (start-process "mrepl (dummy)" (current-buffer) "hexl")))
+      (set-process-query-on-exit-flag proc nil)))
+  (set (make-local-variable 'comint-use-prompt-regexp) nil)
+  (set (make-local-variable 'comint-inhibit-carriage-motion) t)
+  (set (make-local-variable 'comint-input-sender) 'slime-mrepl-input-sender)
+  (set (make-local-variable 'comint-output-filter-functions) nil)
+  (set (make-local-variable 'slime-mrepl-expect-sexp) t)
+  ;;(set (make-local-variable 'comint-get-old-input) 'ielm-get-old-input)
+  (set-syntax-table lisp-mode-syntax-table)
+  )
+
+(slime-define-keys slime-mrepl-mode-map
+  ((kbd "RET") 'slime-mrepl-return)
+  ([return] 'slime-mrepl-return)
+  ;;((kbd "TAB") 'slime-indent-and-complete-symbol)
+  ((kbd "C-c C-b") 'slime-interrupt)
+  ((kbd "C-c C-c") 'slime-interrupt))
+
+(defun slime-mrepl-process% () (get-buffer-process (current-buffer))) ;stupid
+(defun slime-mrepl-mark () (process-mark (slime-mrepl-process%)))
+
+(defun slime-mrepl-insert (string)
+  (comint-output-filter (slime-mrepl-process%) string))
+
+(slime-define-channel-type listener)
+
+(slime-define-channel-method listener :prompt (package prompt)
+  (with-current-buffer (slime-channel-get self 'buffer)
+    (slime-mrepl-prompt package prompt)))
+
+(defun slime-mrepl-prompt (package prompt)
+  (setf slime-buffer-package package)
+  (slime-mrepl-insert (format "%s%s> "
+			      (cl-case (current-column)
+				(0 "")
+				(t "\n"))
+			      prompt))
+  (slime-mrepl-recenter))
+
+(defun slime-mrepl-recenter ()
+  (when (get-buffer-window)
+    (recenter -1)))
+
+(slime-define-channel-method listener :write-result (result)
+  (with-current-buffer (slime-channel-get self 'buffer)
+    (goto-char (point-max))
+    (slime-mrepl-insert result)))
+
+(slime-define-channel-method listener :evaluation-aborted ()
+  (with-current-buffer (slime-channel-get self 'buffer)
+    (goto-char (point-max))
+    (slime-mrepl-insert "; Evaluation aborted\n")))
+
+(slime-define-channel-method listener :write-string (string)
+  (slime-mrepl-write-string self string))
+
+(defun slime-mrepl-write-string (self string)
+  (with-current-buffer (slime-channel-get self 'buffer)
+    (goto-char (slime-mrepl-mark))
+    (slime-mrepl-insert string)))
+
+(slime-define-channel-method listener :set-read-mode (mode)
+  (with-current-buffer (slime-channel-get self 'buffer)
+    (cl-ecase mode
+      (:read (setq slime-mrepl-expect-sexp nil)
+	     (message "[Listener is waiting for input]"))
+      (:eval (setq slime-mrepl-expect-sexp t)))))
+
+(defun slime-mrepl-return (&optional end-of-input)
+  (interactive "P")
+  (slime-check-connected)
+  (goto-char (point-max))
+  (cond ((and slime-mrepl-expect-sexp
+	      (or (slime-input-complete-p (slime-mrepl-mark) (point))
+		  end-of-input))
+	 (comint-send-input))
+	((not slime-mrepl-expect-sexp)
+	 (unless end-of-input
+	   (insert "\n"))
+	 (comint-send-input t))
+        (t
+	 (insert "\n")
+	 (inferior-slime-indent-line)
+         (message "[input not complete]")))
+  (slime-mrepl-recenter))
+
+(defun slime-mrepl-input-sender (proc string)
+  (slime-mrepl-send-string (substring-no-properties string)))
+
+(defun slime-mrepl-send-string (string &optional command-string)
+  (slime-mrepl-send `(:process ,string)))
+
+(defun slime-mrepl-send (msg)
+  "Send MSG to the remote channel."
+  (slime-send-to-remote-channel slime-mrepl-remote-channel msg))
+
+(defun slime-new-mrepl ()
+  "Create a new listener window."
+  (interactive)
+  (let ((channel (slime-make-channel slime-listener-channel-methods)))
+    (slime-eval-async
+        `(swank-mrepl:create-mrepl ,(slime-channel.id channel))
+      (slime-rcurry 
+       (lambda (result channel)
+         (cl-destructuring-bind (remote thread-id package prompt) result
+           (pop-to-buffer (generate-new-buffer (slime-buffer-name :mrepl)))
+           (slime-mrepl-mode)
+           (setq slime-current-thread thread-id)
+           (setq slime-buffer-connection (slime-connection))
+           (set (make-local-variable 'slime-mrepl-remote-channel) remote)
+           (slime-channel-put channel 'buffer (current-buffer))
+           (slime-channel-send channel `(:prompt ,package ,prompt))))
+       channel))))
+
+(defun slime-mrepl ()
+  (let ((conn (slime-connection)))
+    (cl-find-if (lambda (x) 
+	       (with-current-buffer x 
+		 (and (eq major-mode 'slime-mrepl-mode)
+		      (eq (slime-current-connection) conn))))
+	     (buffer-list))))
+
+(def-slime-selector-method ?m
+  "First mrepl-buffer"
+  (or (slime-mrepl)
+      (error "No mrepl buffer (%s)" (slime-connection-name))))
+
+(provide 'slime-mrepl)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-package-fu.el

@@ -0,0 +1,320 @@
+(require 'slime)
+(require 'slime-c-p-c)
+(require 'slime-parse)
+
+(defvar slime-package-fu-init-undo-stack nil)
+
+(define-slime-contrib slime-package-fu
+  "Exporting/Unexporting symbols at point."
+  (:authors "Tobias C. Rittweiler <tcr@freebits.de>")
+  (:license "GPL")
+  (:swank-dependencies swank-package-fu)
+  (:on-load
+   (push `(progn (define-key slime-mode-map "\C-cx"
+                   ',(lookup-key slime-mode-map "\C-cx")))
+         slime-package-fu-init-undo-stack)
+   (define-key slime-mode-map "\C-cx"  'slime-export-symbol-at-point))
+  (:on-unload
+   (while slime-c-p-c-init-undo-stack
+     (eval (pop slime-c-p-c-init-undo-stack)))))
+
+(defvar slime-package-file-candidates
+  (mapcar #'file-name-nondirectory
+          '("package.lisp" "packages.lisp" "pkgdcl.lisp"
+            "defpackage.lisp")))
+
+(defvar slime-export-symbol-representation-function
+  #'(lambda (n) (format "#:%s" n)))
+
+(defvar slime-export-symbol-representation-auto t
+  "Determine automatically which style is used for symbols, #: or :
+If it's mixed or no symbols are exported so far,
+use `slime-export-symbol-representation-function'.")
+
+(defvar slime-export-save-file nil
+  "Save the package file after each automatic modification")
+
+(defvar slime-defpackage-regexp
+  "^(\\(cl:\\|common-lisp:\\)?defpackage\\>[ \t']*")
+
+(defun slime-find-package-definition-rpc (package)
+  (slime-eval `(swank:find-definition-for-thing
+                (swank::guess-package ,package))))
+
+(defun slime-find-package-definition-regexp (package)
+  (save-excursion
+    (save-match-data
+      (goto-char (point-min))
+      (cl-block nil
+        (while (re-search-forward slime-defpackage-regexp nil t)
+          (when (slime-package-equal package (slime-sexp-at-point))
+            (backward-sexp)
+            (cl-return (make-slime-file-location (buffer-file-name)
+                                                 (1- (point))))))))))
+
+(defun slime-package-equal (designator1 designator2)
+  ;; First try to be lucky and compare the strings themselves (for the
+  ;; case when one of the designated packages isn't loaded in the
+  ;; image.) Then try to do it properly using the inferior Lisp which
+  ;; will also resolve nicknames for us &c.
+  (or (cl-equalp (slime-cl-symbol-name designator1)
+                 (slime-cl-symbol-name designator2))
+      (slime-eval `(swank:package= ,designator1 ,designator2))))
+
+(defun slime-export-symbol (symbol package)
+  "Unexport `symbol' from `package' in the Lisp image."
+  (slime-eval `(swank:export-symbol-for-emacs ,symbol ,package)))
+
+(defun slime-unexport-symbol (symbol package)
+  "Export `symbol' from `package' in the Lisp image."
+  (slime-eval `(swank:unexport-symbol-for-emacs ,symbol ,package)))
+
+
+(defun slime-find-possible-package-file (buffer-file-name)
+  (cl-labels ((file-name-subdirectory (dirname)
+                                      (expand-file-name
+                                       (concat (file-name-as-directory (slime-to-lisp-filename dirname))
+                                               (file-name-as-directory ".."))))
+              (try (dirname)
+                   (cl-dolist (package-file-name slime-package-file-candidates)
+                     (let ((f (slime-to-lisp-filename
+                               (concat dirname package-file-name))))
+                       (when (file-readable-p f)
+                         (cl-return f))))))
+    (when buffer-file-name
+      (let ((buffer-cwd (file-name-directory buffer-file-name)))
+        (or (try buffer-cwd)
+            (try (file-name-subdirectory buffer-cwd))
+            (try (file-name-subdirectory
+                  (file-name-subdirectory buffer-cwd))))))))
+
+(defun slime-goto-package-source-definition (package)
+  "Tries to find the DEFPACKAGE form of `package'. If found,
+places the cursor at the start of the DEFPACKAGE form."
+  (cl-labels ((try (location)
+                   (when (slime-location-p location)
+                     (slime-goto-source-location location)
+                     t)))
+    (or (try (slime-find-package-definition-rpc package))
+        (try (slime-find-package-definition-regexp package))
+        (try (let ((package-file (slime-find-possible-package-file
+                                  (buffer-file-name))))
+               (when package-file
+                 (with-current-buffer (find-file-noselect package-file t)
+                   (slime-find-package-definition-regexp package)))))
+        (error "Couldn't find source definition of package: %s" package))))
+
+(defun slime-at-expression-p (pattern)
+  (when (ignore-errors
+          ;; at a list?
+          (= (point) (progn (down-list 1)
+                            (backward-up-list 1)
+                            (point))))
+    (save-excursion
+      (down-list 1)
+      (slime-in-expression-p pattern))))
+
+(defun slime-goto-next-export-clause ()
+  ;; Assumes we're inside the beginning of a DEFPACKAGE form.
+  (let ((point))
+    (save-excursion
+      (cl-block nil
+        (while (ignore-errors (slime-forward-sexp) t)
+          (skip-chars-forward " \n\t")
+          (when (slime-at-expression-p '(:export *))
+            (setq point (point))
+            (cl-return)))))
+    (if point
+        (goto-char point)
+      (error "No next (:export ...) clause found"))))
+
+(defun slime-search-exports-in-defpackage (symbol-name)
+  "Look if `symbol-name' is mentioned in one of the :EXPORT clauses."
+  ;; Assumes we're inside the beginning of a DEFPACKAGE form.
+  (cl-labels ((target-symbol-p (symbol)
+                               (string-match-p (format "^\\(\\(#:\\)\\|:\\)?%s$"
+                                                       (regexp-quote symbol-name))
+                                               symbol)))
+    (save-excursion
+      (cl-block nil
+        (while (ignore-errors (slime-goto-next-export-clause) t)
+          (let ((clause-end (save-excursion (forward-sexp) (point))))
+            (save-excursion
+              (while (search-forward symbol-name clause-end t)
+                (when (target-symbol-p (slime-symbol-at-point))
+                  (cl-return (if (slime-inside-string-p)
+                                 ;; Include the following "
+                                 (1+ (point))
+                               (point))))))))))))
+
+(defun slime-export-symbols ()
+  "Return a list of symbols inside :export clause of a defpackage."
+  ;; Assumes we're at the beginning of :export
+  (cl-labels ((read-sexp ()
+                         (ignore-errors
+                           (forward-comment (point-max))
+                           (buffer-substring-no-properties
+                            (point) (progn (forward-sexp) (point))))))
+    (save-excursion
+      (cl-loop for sexp = (read-sexp) while sexp collect sexp))))
+
+(defun slime-defpackage-exports ()
+  "Return a list of symbols inside :export clause of a defpackage."
+  ;; Assumes we're inside the beginning of a DEFPACKAGE form.
+  (cl-labels ((normalize-name (name)
+                              (if (string-prefix-p "\"" name)
+                                  (read name)
+                                (replace-regexp-in-string "^\\(\\(#:\\)\\|:\\)"
+                                                          "" name))))
+    (save-excursion
+      (mapcar #'normalize-name
+              (cl-loop while (ignore-errors (slime-goto-next-export-clause) t)
+                       do (down-list) (forward-sexp)
+                       append (slime-export-symbols)
+                       do (up-list) (backward-sexp))))))
+
+(defun slime-symbol-exported-p (name symbols)
+  (cl-member name symbols :test 'cl-equalp))
+
+(defun slime-frob-defpackage-form (current-package do-what symbols)
+  "Adds/removes `symbol' from the DEFPACKAGE form of `current-package'
+depending on the value of `do-what' which can either be `:export',
+or `:unexport'.
+
+Returns t if the symbol was added/removed. Nil if the symbol was
+already exported/unexported."
+  (save-excursion
+    (slime-goto-package-source-definition current-package)
+    (down-list 1)                       ; enter DEFPACKAGE form
+    (forward-sexp)                      ; skip DEFPACKAGE symbol
+    ;; Don't or will fail if (:export ...) is immediately following
+    ;; (forward-sexp)                   ; skip package name
+    (let ((exported-symbols (slime-defpackage-exports))
+          (symbols (if (consp symbols)
+                       symbols
+                     (list symbols)))
+          (number-of-actions 0))
+      (cl-ecase do-what
+        (:export
+         (slime-add-export)
+         (dolist (symbol symbols)
+           (let ((symbol-name (slime-cl-symbol-name symbol)))
+             (unless (slime-symbol-exported-p symbol-name exported-symbols)
+               (cl-incf number-of-actions)
+               (slime-insert-export symbol-name)))))
+        (:unexport
+         (dolist (symbol symbols)
+           (let ((symbol-name (slime-cl-symbol-name symbol)))
+             (when (slime-symbol-exported-p symbol-name exported-symbols)
+               (slime-remove-export symbol-name)
+               (cl-incf number-of-actions))))))
+      (when slime-export-save-file
+        (save-buffer))
+      number-of-actions)))
+
+(defun slime-add-export ()
+  (let (point)
+    (save-excursion
+      (while (ignore-errors (slime-goto-next-export-clause) t)
+        (setq point (point))))
+    (cond (point
+           (goto-char point)
+           (down-list)
+           (slime-end-of-list))
+          (t
+           (slime-end-of-list)
+           (unless (looking-back "^\\s-*")
+             (newline-and-indent))
+           (insert "(:export ")
+           (save-excursion (insert ")"))))))
+
+(defun slime-determine-symbol-style ()
+  ;; Assumes we're inside :export
+  (save-excursion
+    (slime-beginning-of-list)
+    (slime-forward-sexp)
+    (let ((symbols (slime-export-symbols)))
+      (cond ((null symbols)
+             slime-export-symbol-representation-function)
+            ((cl-every (lambda (x)
+                         (string-match "^:" x))
+                       symbols)
+             (lambda (n) (format ":%s" n)))
+            ((cl-every (lambda (x)
+                         (string-match "^#:" x))
+                       symbols)
+             (lambda (n) (format "#:%s" n)))
+            ((cl-every (lambda (x)
+                         (string-prefix-p "\"" x))
+                       symbols)
+             (lambda (n) (prin1-to-string (upcase (substring-no-properties n)))))
+            (t
+             slime-export-symbol-representation-function)))))
+
+(defun slime-format-symbol-for-defpackage (symbol-name)
+  (funcall (if slime-export-symbol-representation-auto
+               (slime-determine-symbol-style)
+             slime-export-symbol-representation-function)
+           symbol-name))
+
+(defun slime-insert-export (symbol-name)
+  ;; Assumes we're at the inside :export after the last symbol
+  (let ((symbol-name (slime-format-symbol-for-defpackage symbol-name)))
+    (unless (looking-back "^\\s-*")
+      (newline-and-indent))
+    (insert symbol-name)))
+
+(defun slime-remove-export (symbol-name)
+  ;; Assumes we're inside the beginning of a DEFPACKAGE form.
+  (let ((point))
+    (while (setq point (slime-search-exports-in-defpackage symbol-name))
+      (save-excursion
+        (goto-char point)
+        (backward-sexp)
+        (delete-region (point) point)
+        (beginning-of-line)
+        (when (looking-at "^\\s-*$")
+          (join-line)
+          (delete-trailing-whitespace (point) (line-end-position)))))))
+
+(defun slime-export-symbol-at-point ()
+  "Add the symbol at point to the defpackage source definition
+belonging to the current buffer-package. With prefix-arg, remove
+the symbol again. Additionally performs an EXPORT/UNEXPORT of the
+symbol in the Lisp image if possible."
+  (interactive)
+  (let ((package (slime-current-package))
+        (symbol (slime-symbol-at-point)))
+    (unless symbol (error "No symbol at point."))
+    (cond (current-prefix-arg
+           (if (cl-plusp (slime-frob-defpackage-form package :unexport symbol))
+               (message "Symbol `%s' no longer exported form `%s'"
+                        symbol package)
+             (message "Symbol `%s' is not exported from `%s'"
+                      symbol package))
+           (slime-unexport-symbol symbol package))
+          (t
+           (if (cl-plusp (slime-frob-defpackage-form package :export symbol))
+               (message "Symbol `%s' now exported from `%s'"
+                        symbol package)
+             (message "Symbol `%s' already exported from `%s'"
+                      symbol package))
+           (slime-export-symbol symbol package)))))
+
+(defun slime-export-class (name)
+  "Export acessors, constructors, etc. associated with a structure or a class"
+  (interactive (list (slime-read-from-minibuffer "Export structure named: "
+                                                 (slime-symbol-at-point))))
+  (let* ((package (slime-current-package))
+         (symbols (slime-eval `(swank:export-structure ,name ,package))))
+    (message "%s symbols exported from `%s'"
+             (slime-frob-defpackage-form package :export symbols)
+             package)))
+
+(defalias 'slime-export-structure 'slime-export-class)
+
+(provide 'slime-package-fu)
+
+;; Local Variables:
+;; indent-tabs-mode: nil
+;; End:

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-parse.el

@@ -0,0 +1,358 @@
+(require 'slime)
+(require 'cl-lib)
+
+(define-slime-contrib slime-parse
+  "Utility contrib containg functions to parse forms in a buffer."
+  (:authors "Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>"
+            "Tobias C. Rittweiler <tcr@freebits.de>")
+  (:license "GPL"))
+
+(defun slime-parse-form-until (limit form-suffix)
+  "Parses form from point to `limit'."
+  ;; For performance reasons, this function does not use recursion.
+  (let ((todo (list (point))) ; stack of positions
+        (sexps)               ; stack of expressions
+        (cursexp)
+        (curpos)
+        (depth 1))            ; This function must be called from the
+                                        ; start of the sexp to be parsed.
+    (while (and (setq curpos (pop todo))
+                (progn
+                  (goto-char curpos)
+                  ;; (Here we also move over suppressed
+                  ;; reader-conditionalized code! Important so CL-side
+                  ;; of autodoc won't see that garbage.)
+                  (ignore-errors (slime-forward-cruft))
+                  (< (point) limit)))
+      (setq cursexp (pop sexps))
+      (cond
+       ;; End of an sexp?
+       ((or (looking-at "\\s)") (eolp))
+        (cl-decf depth)
+        (push (nreverse cursexp) (car sexps)))
+       ;; Start of a new sexp?
+       ((looking-at "\\s'*@*\\s(")
+        (let ((subpt (match-end 0)))
+          (ignore-errors
+            (forward-sexp)
+            ;; (In case of error, we're at an incomplete sexp, and
+            ;; nothing's left todo after it.)
+            (push (point) todo))
+          (push cursexp sexps)
+          (push subpt todo)            ; to descend into new sexp
+          (push nil sexps)
+          (cl-incf depth)))
+       ;; In mid of an sexp..
+       (t
+        (let ((pt1 (point))
+              (pt2 (condition-case e
+                       (progn (forward-sexp) (point))
+                     (scan-error
+                      (cl-fourth e)))))   ; end of sexp
+          (push (buffer-substring-no-properties pt1 pt2) cursexp)
+          (push pt2 todo)
+          (push cursexp sexps)))))
+    (when sexps
+      (setf (car sexps) (cl-nreconc form-suffix (car sexps)))
+      (while (> depth 1)
+        (push (nreverse (pop sexps)) (car sexps))
+        (cl-decf depth))
+      (nreverse (car sexps)))))
+
+(defun slime-compare-char-syntax (get-char-fn syntax &optional unescaped)
+  "Returns t if the character that `get-char-fn' yields has
+characer syntax of `syntax'. If `unescaped' is true, it's ensured
+that the character is not escaped."
+  (let ((char        (funcall get-char-fn (point)))
+	(char-before (funcall get-char-fn (1- (point)))))
+    (if (and char (eq (char-syntax char) (aref syntax 0)))
+	(if unescaped
+	    (or (null char-before)
+		(not (eq (char-syntax char-before) ?\\)))
+          t)
+      nil)))
+
+(defconst slime-cursor-marker 'swank::%cursor-marker%)
+
+(defun slime-parse-form-upto-point (&optional max-levels)
+  (save-restriction
+    ;; Don't parse more than 500 lines before point, so we don't spend
+    ;; too much time. NB. Make sure to go to beginning of line, and
+    ;; not possibly anywhere inside comments or strings.
+    (narrow-to-region (line-beginning-position -500) (point-max))
+    (save-excursion
+      (let ((suffix (list slime-cursor-marker)))
+        (cond ((slime-compare-char-syntax #'char-after "(" t)
+               ;; We're at the start of some expression, so make sure
+               ;; that SWANK::%CURSOR-MARKER% will come after that
+               ;; expression. If the expression is not balanced, make
+               ;; still sure that the marker does *not* come directly
+               ;; after the preceding expression.
+               (or (ignore-errors (forward-sexp) t)
+                   (push "" suffix)))
+              ((or (bolp) (slime-compare-char-syntax #'char-before " " t))
+               ;; We're after some expression, so we have to make sure
+               ;; that %CURSOR-MARKER% does *not* come directly after
+               ;; that expression.
+               (push "" suffix))
+              ((slime-compare-char-syntax #'char-before "(" t)
+               ;; We're directly after an opening parenthesis, so we
+               ;; have to make sure that something comes before
+               ;; %CURSOR-MARKER%.
+               (push "" suffix))
+              (t
+               ;; We're at a symbol, so make sure we get the whole symbol.
+               (slime-end-of-symbol)))
+        (let ((pt (point)))
+          (ignore-errors (up-list (if max-levels (- max-levels) -5)))
+          (ignore-errors (down-list))
+          (slime-parse-form-until pt suffix))))))
+
+(require 'bytecomp)
+
+(mapc (lambda (sym)
+        (cond ((fboundp sym)
+               (unless (byte-code-function-p (symbol-function sym))
+                 (byte-compile sym)))
+              (t (error "%S is not fbound" sym))))
+      '(slime-parse-form-upto-point
+        slime-parse-form-until
+        slime-compare-char-syntax))
+
+;;;; Test cases
+(defun slime-extract-context ()
+  "Parse the context for the symbol at point.
+Nil is returned if there's no symbol at point.  Otherwise we detect
+the following cases (the . shows the point position):
+
+ (defun n.ame (...) ...)                 -> (:defun name)
+ (defun (setf n.ame) (...) ...)          -> (:defun (setf name))
+ (defmethod n.ame (...) ...)             -> (:defmethod name (...))
+ (defun ... (...) (labels ((n.ame (...)  -> (:labels (:defun ...) name)
+ (defun ... (...) (flet ((n.ame (...)    -> (:flet (:defun ...) name)
+ (defun ... (...) ... (n.ame ...) ...)   -> (:call (:defun ...) name)
+ (defun ... (...) ... (setf (n.ame ...)  -> (:call (:defun ...) (setf name))
+
+ (defmacro n.ame (...) ...)              -> (:defmacro name)
+ (defsetf n.ame (...) ...)               -> (:defsetf name)
+ (define-setf-expander n.ame (...) ...)  -> (:define-setf-expander name)
+ (define-modify-macro n.ame (...) ...)   -> (:define-modify-macro name)
+ (define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name)
+ (defvar n.ame (...) ...)                -> (:defvar name)
+ (defparameter n.ame ...)                -> (:defparameter name)
+ (defconstant n.ame ...)                 -> (:defconstant name)
+ (defclass n.ame ...)                    -> (:defclass name)
+ (defstruct n.ame ...)                   -> (:defstruct name)
+ (defpackage n.ame ...)                  -> (:defpackage name)
+For other contexts we return the symbol at point."
+  (let ((name (slime-symbol-at-point)))
+    (if name
+        (let ((symbol (read name)))
+          (or (progn ;;ignore-errors
+                (slime-parse-context symbol))
+              symbol)))))
+
+(defun slime-parse-context (name)
+  (save-excursion
+    (cond ((slime-in-expression-p '(defun *))          `(:defun ,name))
+          ((slime-in-expression-p '(defmacro *))       `(:defmacro ,name))
+          ((slime-in-expression-p '(defgeneric *))     `(:defgeneric ,name))
+          ((slime-in-expression-p '(setf *))
+           ;;a setf-definition, but which?
+           (backward-up-list 1)
+           (slime-parse-context `(setf ,name)))
+          ((slime-in-expression-p '(defmethod *))
+           (unless (looking-at "\\s ")
+             (forward-sexp 1)) ; skip over the methodname
+           (let (qualifiers arglist)
+             (cl-loop for e = (read (current-buffer))
+                      until (listp e) do (push e qualifiers)
+                      finally (setq arglist e))
+             `(:defmethod ,name ,@qualifiers
+                          ,(slime-arglist-specializers arglist))))
+          ((and (symbolp name)
+                (slime-in-expression-p `(,name)))
+           ;; looks like a regular call
+           (let ((toplevel (ignore-errors (slime-parse-toplevel-form))))
+             (cond ((slime-in-expression-p `(setf (*)))  ;a setf-call
+                    (if toplevel
+                        `(:call ,toplevel (setf ,name))
+                      `(setf ,name)))
+                   ((not toplevel)
+                    name)
+                   ((slime-in-expression-p `(labels ((*))))
+                    `(:labels ,toplevel ,name))
+                   ((slime-in-expression-p `(flet ((*))))
+                    `(:flet ,toplevel ,name))
+                   (t
+                    `(:call ,toplevel ,name)))))
+          ((slime-in-expression-p '(define-compiler-macro *))
+           `(:define-compiler-macro ,name))
+          ((slime-in-expression-p '(define-modify-macro *))
+           `(:define-modify-macro ,name))
+          ((slime-in-expression-p '(define-setf-expander *))
+           `(:define-setf-expander ,name))
+          ((slime-in-expression-p '(defsetf *))
+           `(:defsetf ,name))
+          ((slime-in-expression-p '(defvar *))       `(:defvar ,name))
+          ((slime-in-expression-p '(defparameter *)) `(:defparameter ,name))
+          ((slime-in-expression-p '(defconstant *))  `(:defconstant ,name))
+          ((slime-in-expression-p '(defclass *))     `(:defclass ,name))
+          ((slime-in-expression-p '(defpackage *))   `(:defpackage ,name))
+          ((slime-in-expression-p '(defstruct *))
+           `(:defstruct ,(if (consp name)
+                             (car name)
+                           name)))
+          (t
+           name))))
+
+
+(defun slime-in-expression-p (pattern)
+  "A helper function to determine the current context.
+The pattern can have the form:
+ pattern ::= ()    ;matches always
+           | (*)   ;matches inside a list
+           | (<symbol> <pattern>)   ;matches if the first element in
+				    ; the current list is <symbol> and
+                                    ; if <pattern> matches.
+           | ((<pattern>))          ;matches if we are in a nested list."
+  (save-excursion
+    (let ((path (reverse (slime-pattern-path pattern))))
+      (cl-loop for p in path
+               always (ignore-errors
+                        (cl-etypecase p
+                          (symbol (slime-beginning-of-list)
+                                  (eq (read (current-buffer)) p))
+                          (number (backward-up-list p)
+                                  t)))))))
+
+(defun slime-pattern-path (pattern)
+  ;; Compute the path to the * in the pattern to make matching
+  ;; easier. The path is a list of symbols and numbers.  A number
+  ;; means "(down-list <n>)" and a symbol "(look-at <sym>)")
+  (if (null pattern)
+      '()
+    (cl-etypecase (car pattern)
+      ((member *) '())
+      (symbol (cons (car pattern) (slime-pattern-path (cdr pattern))))
+      (cons (cons 1 (slime-pattern-path (car pattern)))))))
+
+(defun slime-beginning-of-list (&optional up)
+  "Move backward to the beginning of the current expression.
+Point is placed before the first expression in the list."
+  (backward-up-list (or up 1))
+  (down-list 1)
+  (skip-syntax-forward " "))
+
+(defun slime-end-of-list (&optional up)
+  (backward-up-list (or up 1))
+  (forward-list 1)
+  (down-list -1))
+
+(defun slime-parse-toplevel-form ()
+  (ignore-errors                        ; (foo)
+    (save-excursion
+      (goto-char (car (slime-region-for-defun-at-point)))
+      (down-list 1)
+      (forward-sexp 1)
+      (slime-parse-context (read (current-buffer))))))
+
+(defun slime-arglist-specializers (arglist)
+  (cond ((or (null arglist)
+	     (member (cl-first arglist) '(&optional &key &rest &aux)))
+	 (list))
+	((consp (cl-first arglist))
+	 (cons (cl-second (cl-first arglist))
+	       (slime-arglist-specializers (cl-rest arglist))))
+	(t
+	 (cons 't
+	       (slime-arglist-specializers (cl-rest arglist))))))
+
+(defun slime-definition-at-point (&optional only-functional)
+  "Return object corresponding to the definition at point."
+  (let ((toplevel (slime-parse-toplevel-form)))
+    (if (or (symbolp toplevel)
+            (and only-functional
+                 (not (member (car toplevel)
+                              '(:defun :defgeneric :defmethod
+                                       :defmacro :define-compiler-macro)))))
+        (error "Not in a definition")
+      (slime-dcase toplevel
+        (((:defun :defgeneric) symbol)
+         (format "#'%s" symbol))
+        (((:defmacro :define-modify-macro) symbol)
+         (format "(macro-function '%s)" symbol))
+        ((:define-compiler-macro symbol)
+         (format "(compiler-macro-function '%s)" symbol))
+        ((:defmethod symbol &rest args)
+         (declare (ignore args))
+         (format "#'%s" symbol))
+        (((:defparameter :defvar :defconstant) symbol)
+         (format "'%s" symbol))
+        (((:defclass :defstruct) symbol)
+         (format "(find-class '%s)" symbol))
+        ((:defpackage symbol)
+         (format "(or (find-package '%s) (error \"Package %s not found\"))"
+                 symbol symbol))
+        (t
+         (error "Not in a definition"))))))
+
+(defsubst slime-current-parser-state ()
+  ;; `syntax-ppss' does not save match data as it invokes
+  ;; `beginning-of-defun' implicitly which does not save match
+  ;; data. This issue has been reported to the Emacs maintainer on
+  ;; Feb27.
+  (syntax-ppss))
+
+(defun slime-inside-string-p ()
+  (nth 3 (slime-current-parser-state)))
+
+(defun slime-inside-comment-p ()
+  (nth 4 (slime-current-parser-state)))
+
+(defun slime-inside-string-or-comment-p ()
+  (let ((state (slime-current-parser-state)))
+    (or (nth 3 state) (nth 4 state))))
+
+;;; The following two functions can be handy when inspecting
+;;; source-location while debugging `M-.'.
+;;;
+(defun slime-current-tlf-number ()
+  "Return the current toplevel number."
+  (interactive)
+  (let ((original-pos (car (slime-region-for-defun-at-point)))
+        (n 0))
+    (save-excursion
+      ;; We use this and no repeated `beginning-of-defun's to get
+      ;; reader conditionals right.
+      (goto-char (point-min))
+      (while (progn (slime-forward-sexp)
+                    (< (point) original-pos))
+        (cl-incf n)))
+    n))
+
+;;; This is similiar to `slime-enclosing-form-paths' in the
+;;; `slime-parse' contrib except that this does not do any duck-tape
+;;; parsing, and gets reader conditionals right.
+(defun slime-current-form-path ()
+  "Returns the path from the beginning of the current toplevel
+form to the atom at point, or nil if we're in front of a tlf."
+  (interactive)
+  (let ((source-path nil))
+    (save-excursion
+      ;; Moving forward to get reader conditionals right.
+      (cl-loop for inner-pos = (point)
+               for outer-pos = (cl-nth-value 1 (slime-current-parser-state))
+               while outer-pos do
+               (goto-char outer-pos)
+               (unless (eq (char-before) ?#) ; when at #(...) continue.
+                 (forward-char)
+                 (let ((n 0))
+                   (while (progn (slime-forward-sexp)
+                                 (< (point) inner-pos))
+                     (cl-incf n))
+                   (push n source-path)
+                   (goto-char outer-pos)))))
+    source-path))
+
+(provide 'slime-parse)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-presentation-streams.el

@@ -0,0 +1,18 @@
+(eval-and-compile
+  (require 'slime))
+
+(define-slime-contrib slime-presentation-streams
+  "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 "GPL")
+  (:on-load
+   (add-hook 'slime-connected-hook 'slime-presentation-streams-on-connected))
+  (:swank-dependencies swank-presentation-streams))
+
+(defun slime-presentation-streams-on-connected ()
+  (slime-eval `(swank:init-presentation-streams)))
+
+(provide 'slime-presentation-streams)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-presentations.el

@@ -0,0 +1,872 @@
+(require 'slime)
+(require 'bridge)
+(require 'cl-lib)
+(eval-when-compile
+  (require 'cl))
+
+(define-slime-contrib slime-presentations
+  "Imitate LispM presentations."
+  (:authors "Alan Ruttenberg  <alanr-l@mumble.net>"
+            "Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>")
+  (:license "GPL")
+  (:slime-dependencies slime-repl)
+  (:swank-dependencies swank-presentations)
+  (:on-load
+   (add-hook 'slime-repl-mode-hook
+             (lambda ()
+               ;; Respect the syntax text properties of presentation.
+               (set (make-local-variable 'parse-sexp-lookup-properties) t)
+               (add-hook 'after-change-functions
+                         'slime-after-change-function 'append t)))
+   (add-hook 'slime-event-hooks 'slime-dispatch-presentation-event)
+   (setq slime-write-string-function 'slime-presentation-write)
+   (add-hook 'slime-connected-hook 'slime-presentations-on-connected)
+   (add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed)
+   (add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input)
+   (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open)
+   (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations)
+   (add-hook 'slime-edit-definition-hooks 'slime-edit-presentation)
+   (setq sldb-insert-frame-variable-value-function
+         'slime-presentation-sldb-insert-frame-variable-value)
+   (slime-presentation-init-keymaps)
+   (slime-presentation-add-easy-menu)))
+
+;; To get presentations in the inspector as well, add this to your
+;; init file.
+;;
+;; (eval-after-load 'slime-presentations
+;;    '(setq slime-inspector-insert-ispec-function
+;;           'slime-presentation-inspector-insert-ispec))
+;;
+(defface slime-repl-output-mouseover-face
+    '((t (:box (:line-width 1 :color "black" :style released-button)
+          :inherit slime-repl-inputed-output-face)))
+  "Face for Lisp output in the SLIME REPL, when the mouse hovers over it"
+  :group 'slime-repl)
+
+(defface slime-repl-inputed-output-face
+  '((((class color) (background light)) (:foreground "Red"))
+    (((class color) (background dark)) (:foreground "Red"))
+    (t (:slant italic)))
+  "Face for the result of an evaluation in the SLIME REPL."
+  :group 'slime-repl)
+
+;; FIXME: This conditional is not right - just used because the code
+;; here does not work in XEmacs.
+(when (boundp 'text-property-default-nonsticky)
+  (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky
+	   :test 'equal)
+  (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky
+	   :test 'equal))
+
+(make-variable-buffer-local
+ (defvar slime-presentation-start-to-point (make-hash-table)))
+
+(defun slime-mark-presentation-start (id &optional target)
+  "Mark the beginning of a presentation with the given ID.
+TARGET can be nil (regular process output) or :repl-result."
+  (setf (gethash id slime-presentation-start-to-point)
+        ;; We use markers because text can also be inserted before this presentation.
+        ;; (Output arrives while we are writing presentations within REPL results.)
+        (copy-marker (slime-repl-output-target-marker target) nil)))
+
+(defun slime-mark-presentation-start-handler (process string)
+  (if (and string (string-match "<\\([-0-9]+\\)" string))
+      (let* ((match (substring string (match-beginning 1) (match-end 1)))
+             (id (car (read-from-string match))))
+        (slime-mark-presentation-start id))))
+
+(defun slime-mark-presentation-end (id &optional target)
+  "Mark the end of a presentation with the given ID.
+TARGET can be nil (regular process output) or :repl-result."
+  (let ((start (gethash id slime-presentation-start-to-point)))
+    (remhash id slime-presentation-start-to-point)
+    (when start
+      (let* ((marker (slime-repl-output-target-marker target))
+             (buffer (and marker (marker-buffer marker))))
+        (with-current-buffer buffer
+          (let ((end (marker-position marker)))
+            (slime-add-presentation-properties start end
+                                               id nil)))))))
+
+(defun slime-mark-presentation-end-handler (process string)
+  (if (and string (string-match ">\\([-0-9]+\\)" string))
+      (let* ((match (substring string (match-beginning 1) (match-end 1)))
+             (id (car (read-from-string match))))
+        (slime-mark-presentation-end id))))
+
+(cl-defstruct slime-presentation text id)
+
+(defvar slime-presentation-syntax-table
+  (let ((table (copy-syntax-table lisp-mode-syntax-table)))
+    ;; We give < and > parenthesis syntax, so that #< ... > is treated
+    ;; as a balanced expression.  This allows to use C-M-k, C-M-SPC,
+    ;; etc. to deal with a whole presentation.  (For Lisp mode, this
+    ;; is not desirable, since we do not wish to get a mismatched
+    ;; paren highlighted everytime we type < or >.)
+    (modify-syntax-entry ?< "(>" table)
+    (modify-syntax-entry ?> ")<" table)
+    table)
+  "Syntax table for presentations.")
+
+(defun slime-add-presentation-properties (start end id result-p)
+  "Make the text between START and END a presentation with ID.
+RESULT-P decides whether a face for a return value or output text is used."
+  (let* ((text (buffer-substring-no-properties start end))
+         (presentation (make-slime-presentation :text text :id id)))
+    (let ((inhibit-modification-hooks t))
+      (add-text-properties start end
+                           `(modification-hooks (slime-after-change-function)
+                             insert-in-front-hooks (slime-after-change-function)
+                             insert-behind-hooks (slime-after-change-function)
+                             syntax-table ,slime-presentation-syntax-table
+                             rear-nonsticky t))
+      ;; Use the presentation as the key of a text property
+      (case (- end start)
+        (0)
+        (1
+         (add-text-properties start end
+                              `(slime-repl-presentation ,presentation
+                                ,presentation :start-and-end)))
+        (t
+         (add-text-properties start (1+ start)
+                              `(slime-repl-presentation ,presentation
+                                ,presentation :start))
+         (when (> (- end start) 2)
+           (add-text-properties (1+ start) (1- end)
+                                `(,presentation :interior)))
+         (add-text-properties (1- end) end
+                              `(slime-repl-presentation ,presentation
+                                ,presentation :end))))
+      ;; Also put an overlay for the face and the mouse-face.  This enables
+      ;; highlighting of nested presentations.  However, overlays get lost
+      ;; when we copy a presentation; their removal is also not undoable.
+      ;; In these cases the mouse-face text properties need to take over ---
+      ;; but they do not give nested highlighting.
+      (slime-ensure-presentation-overlay start end presentation))))
+
+(defvar slime-presentation-map (make-sparse-keymap))
+
+(defun slime-ensure-presentation-overlay (start end presentation)
+  (unless (cl-find presentation (overlays-at start)
+                   :key (lambda (overlay)
+                          (overlay-get overlay 'slime-repl-presentation)))
+    (let ((overlay (make-overlay start end (current-buffer) t nil)))
+      (overlay-put overlay 'slime-repl-presentation presentation)
+      (overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face)
+      (overlay-put overlay 'help-echo
+                   (if (eq major-mode 'slime-repl-mode)
+                       "mouse-2: copy to input; mouse-3: menu"
+                     "mouse-2: inspect; mouse-3: menu"))
+      (overlay-put overlay 'face 'slime-repl-inputed-output-face)
+      (overlay-put overlay 'keymap slime-presentation-map))))
+
+(defun slime-remove-presentation-properties (from to presentation)
+  (let ((inhibit-read-only t))
+    (remove-text-properties from to
+                            `(,presentation t syntax-table t rear-nonsticky t))
+    (when (eq (get-text-property from 'slime-repl-presentation) presentation)
+      (remove-text-properties from (1+ from) `(slime-repl-presentation t)))
+    (when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation)
+      (remove-text-properties (1- to) to `(slime-repl-presentation t)))
+    (dolist (overlay (overlays-at from))
+      (when (eq (overlay-get overlay 'slime-repl-presentation) presentation)
+        (delete-overlay overlay)))))
+
+(defun slime-insert-presentation (string output-id &optional rectangle)
+  "Insert STRING in current buffer and mark it as a presentation
+corresponding to OUTPUT-ID.  If RECTANGLE is true, indent multi-line
+strings to line up below the current point."
+  (cl-labels ((insert-it ()
+                       (if rectangle
+                           (slime-insert-indented string)
+                         (insert string))))
+    (let ((start (point)))
+      (insert-it)
+      (slime-add-presentation-properties start (point) output-id t))))
+
+(defun slime-presentation-whole-p (presentation start end &optional object)
+  (let ((object (or object (current-buffer))))
+    (string= (etypecase object
+               (buffer (with-current-buffer object
+                         (buffer-substring-no-properties start end)))
+               (string (substring-no-properties object start end)))
+             (slime-presentation-text presentation))))
+
+(defun slime-presentations-around-point (point &optional object)
+  (let ((object (or object (current-buffer))))
+    (loop for (key value . rest) on (text-properties-at point object) by 'cddr
+          when (slime-presentation-p key)
+          collect key)))
+
+(defun slime-presentation-start-p (tag)
+  (memq tag '(:start :start-and-end)))
+
+(defun slime-presentation-stop-p (tag)
+  (memq tag '(:end :start-and-end)))
+
+(cl-defun slime-presentation-start (point presentation
+                                          &optional (object (current-buffer)))
+  "Find start of `presentation' at `point' in `object'.
+Return buffer index and whether a start-tag was found."
+  (let* ((this-presentation (get-text-property point presentation object)))
+    (while (not (slime-presentation-start-p this-presentation))
+      (let ((change-point (previous-single-property-change
+                           point presentation object (point-min))))
+        (unless change-point
+          (return-from slime-presentation-start
+            (values (etypecase object
+                      (buffer (with-current-buffer object 1))
+                      (string 0))
+                    nil)))
+        (setq this-presentation (get-text-property change-point
+                                                   presentation object))
+        (unless this-presentation
+          (return-from slime-presentation-start
+            (values point nil)))
+        (setq point change-point)))
+    (values point t)))
+
+(cl-defun slime-presentation-end (point presentation
+                                        &optional (object (current-buffer)))
+  "Find end of presentation at `point' in `object'.  Return buffer
+index (after last character of the presentation) and whether an
+end-tag was found."
+  (let* ((this-presentation (get-text-property point presentation object)))
+    (while (not (slime-presentation-stop-p this-presentation))
+      (let ((change-point (next-single-property-change
+                           point presentation object)))
+        (unless change-point
+          (return-from slime-presentation-end
+            (values (etypecase object
+                      (buffer (with-current-buffer object (point-max)))
+                      (string (length object)))
+                    nil)))
+        (setq point change-point)
+        (setq this-presentation (get-text-property point
+                                                   presentation object))))
+    (if this-presentation
+        (let ((after-end (next-single-property-change point
+                                                      presentation object)))
+          (if (not after-end)
+              (values (etypecase object
+                        (buffer (with-current-buffer object (point-max)))
+                        (string (length object)))
+                      t)
+            (values after-end t)))
+      (values point nil))))
+
+(cl-defun slime-presentation-bounds (point presentation
+                                           &optional (object (current-buffer)))
+  "Return start index and end index of `presentation' around `point'
+in `object', and whether the presentation is complete."
+  (multiple-value-bind (start good-start)
+      (slime-presentation-start point presentation object)
+    (multiple-value-bind (end good-end)
+        (slime-presentation-end point presentation object)
+      (values start end
+              (and good-start good-end
+                   (slime-presentation-whole-p presentation
+                                               start end object))))))
+
+(defun slime-presentation-around-point (point &optional object)
+  "Return presentation, start index, end index, and whether the
+presentation is complete."
+  (let ((object (or object (current-buffer)))
+        (innermost-presentation nil)
+        (innermost-start 0)
+        (innermost-end most-positive-fixnum))
+    (dolist (presentation (slime-presentations-around-point point object))
+      (multiple-value-bind (start end whole-p)
+          (slime-presentation-bounds point presentation object)
+        (when whole-p
+          (when (< (- end start) (- innermost-end innermost-start))
+            (setq innermost-start start
+                  innermost-end end
+                  innermost-presentation presentation)))))
+    (values innermost-presentation
+            innermost-start innermost-end)))
+
+(defun slime-presentation-around-or-before-point (point &optional object)
+  (let ((object (or object (current-buffer))))
+    (multiple-value-bind (presentation start end whole-p)
+        (slime-presentation-around-point point object)
+      (if (or presentation (= point (point-min)))
+          (values presentation start end whole-p)
+        (slime-presentation-around-point (1- point) object)))))
+
+(defun slime-presentation-around-or-before-point-or-error (point)
+  (multiple-value-bind (presentation start end whole-p)
+      (slime-presentation-around-or-before-point point)
+    (unless presentation
+      (error "No presentation at point"))
+    (values presentation start end whole-p)))
+
+(cl-defun slime-for-each-presentation-in-region (from to function
+                                                      &optional (object (current-buffer)))
+  "Call `function' with arguments `presentation', `start', `end',
+`whole-p' for every presentation in the region `from'--`to' in the
+string or buffer `object'."
+  (cl-labels ((handle-presentation (presentation point)
+                                   (multiple-value-bind (start end whole-p)
+                                       (slime-presentation-bounds point presentation object)
+                                     (funcall function presentation start end whole-p))))
+    ;; Handle presentations active at `from'.
+    (dolist (presentation (slime-presentations-around-point from object))
+      (handle-presentation presentation from))
+    ;; Use the `slime-repl-presentation' property to search for new presentations.
+    (let ((point from))
+      (while (< point to)
+        (setq point (next-single-property-change point 'slime-repl-presentation
+                                                 object to))
+        (let* ((presentation (get-text-property point 'slime-repl-presentation object))
+               (status (get-text-property point presentation object)))
+          (when (slime-presentation-start-p status)
+            (handle-presentation presentation point)))))))
+
+;; XEmacs compatibility hack, from message by Stephen J. Turnbull on
+;; xemacs-beta@xemacs.org of 18 Mar 2002
+(unless (boundp 'undo-in-progress)
+  (defvar undo-in-progress nil
+    "Placeholder defvar for XEmacs compatibility from SLIME.")
+  (defadvice undo-more (around slime activate)
+    (let ((undo-in-progress t)) ad-do-it)))
+
+(defun slime-after-change-function (start end &rest ignore)
+  "Check all presentations within and adjacent to the change.
+When a presentation has been altered, change it to plain text."
+  (let ((inhibit-modification-hooks t))
+    (let ((real-start (max 1 (1- start)))
+          (real-end   (min (1+ (buffer-size)) (1+ end)))
+          (any-change nil))
+      ;; positions around the change
+      (slime-for-each-presentation-in-region
+       real-start real-end
+       (lambda (presentation from to whole-p)
+         (cond
+          (whole-p
+           (slime-ensure-presentation-overlay from to presentation))
+          ((not undo-in-progress)
+           (slime-remove-presentation-properties from to
+                                                 presentation)
+           (setq any-change t)))))
+      (when any-change
+        (undo-boundary)))))
+
+(defun slime-presentation-around-click (event)
+  "Return the presentation around the position of the mouse-click EVENT.
+If there is no presentation, signal an error.
+Also return the start position, end position, and buffer of the presentation."
+  (when (and (featurep 'xemacs) (not (button-press-event-p event)))
+    (error "Command must be bound to a button-press-event"))
+  (let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event))))
+        (window (if (featurep 'xemacs) (event-window event) (caadr event))))
+    (with-current-buffer (window-buffer window)
+      (multiple-value-bind (presentation start end)
+          (slime-presentation-around-point point)
+        (unless presentation
+          (error "No presentation at click"))
+        (values presentation start end (current-buffer))))))
+
+(defun slime-check-presentation (from to buffer presentation)
+  (unless (slime-eval `(cl:nth-value 1 (swank:lookup-presented-object
+                                        ',(slime-presentation-id presentation))))
+    (with-current-buffer buffer
+      (slime-remove-presentation-properties from to presentation))))
+
+(defun slime-copy-or-inspect-presentation-at-mouse (event)
+  (interactive "e") ; no "@" -- we don't want to select the clicked-at window
+  (multiple-value-bind (presentation start end buffer)
+      (slime-presentation-around-click event)
+    (slime-check-presentation start end buffer presentation)
+    (if (with-current-buffer buffer
+          (eq major-mode 'slime-repl-mode))
+        (slime-copy-presentation-at-mouse-to-repl event)
+      (slime-inspect-presentation-at-mouse event))))
+
+(defun slime-inspect-presentation (presentation start end buffer)
+  (let ((reset-p
+	 (with-current-buffer buffer
+	   (not (eq major-mode 'slime-inspector-mode)))))
+    (slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p)
+      'slime-open-inspector)))
+
+(defun slime-inspect-presentation-at-mouse (event)
+  (interactive "e")
+  (multiple-value-bind (presentation start end buffer)
+      (slime-presentation-around-click event)
+    (slime-inspect-presentation presentation start end buffer)))
+
+(defun slime-inspect-presentation-at-point (point)
+  (interactive "d")
+  (multiple-value-bind (presentation start end)
+      (slime-presentation-around-or-before-point-or-error point)
+    (slime-inspect-presentation presentation start end (current-buffer))))
+
+
+(defun slime-M-.-presentation (presentation start end buffer &optional where)
+  (let* ((id (slime-presentation-id presentation))
+	 (presentation-string (format "Presentation %s" id))
+	 (location (slime-eval `(swank:find-definition-for-thing
+				 (swank:lookup-presented-object
+				  ',(slime-presentation-id presentation))))))
+    (unless (eq (car location) :error)
+      (slime-edit-definition-cont
+       (and location (list (make-slime-xref :dspec `(,presentation-string)
+                                            :location location)))
+       presentation-string
+       where))))
+
+(defun slime-M-.-presentation-at-mouse (event)
+  (interactive "e")
+  (multiple-value-bind (presentation start end buffer)
+      (slime-presentation-around-click event)
+    (slime-M-.-presentation presentation start end buffer)))
+
+(defun slime-M-.-presentation-at-point (point)
+  (interactive "d")
+  (multiple-value-bind (presentation start end)
+      (slime-presentation-around-or-before-point-or-error point)
+    (slime-M-.-presentation presentation start end (current-buffer))))
+
+(defun slime-edit-presentation (name &optional where)
+  (if (or current-prefix-arg (not (equal (slime-symbol-at-point) name)))
+      nil ; NAME came from user explicitly, so decline.
+    (multiple-value-bind (presentation start end whole-p)
+        (slime-presentation-around-or-before-point (point))
+      (when presentation
+        (slime-M-.-presentation presentation start end (current-buffer) where)))))
+
+(defun slime-copy-presentation-to-repl (presentation start end buffer)
+  (let ((text (with-current-buffer buffer
+                ;; we use the buffer-substring rather than the
+                ;; presentation text to capture any overlays
+                (buffer-substring start end)))
+        (id (slime-presentation-id presentation)))
+    (unless (integerp id)
+      (setq id (slime-eval `(swank:lookup-and-save-presented-object-or-lose ',id))))
+    (unless (eql major-mode 'slime-repl-mode)
+      (slime-switch-to-output-buffer))
+    (cl-flet ((do-insertion ()
+                (unless (looking-back "\\s-" (- (point) 1))
+                  (insert " "))
+                (slime-insert-presentation text id)
+                (unless (or (eolp) (looking-at "\\s-"))
+                  (insert " "))))
+      (if (>= (point) slime-repl-prompt-start-mark)
+          (do-insertion)
+        (save-excursion
+          (goto-char (point-max))
+          (do-insertion))))))
+
+(defun slime-copy-presentation-at-mouse-to-repl (event)
+  (interactive "e")
+  (multiple-value-bind (presentation start end buffer)
+      (slime-presentation-around-click event)
+    (slime-copy-presentation-to-repl presentation start end buffer)))
+
+(defun slime-copy-presentation-at-point-to-repl (point)
+  (interactive "d")
+  (multiple-value-bind (presentation start end)
+      (slime-presentation-around-or-before-point-or-error point)
+    (slime-copy-presentation-to-repl presentation start end (current-buffer))))
+
+(defun slime-copy-presentation-at-mouse-to-point (event)
+  (interactive "e")
+  (multiple-value-bind (presentation start end buffer)
+      (slime-presentation-around-click event)
+    (let ((presentation-text
+           (with-current-buffer buffer
+             (buffer-substring start end))))
+      (when (not (string-match "\\s-"
+                               (buffer-substring (1- (point)) (point))))
+        (insert " "))
+      (insert presentation-text)
+      (slime-after-change-function (point) (point))
+      (when (and (not (eolp)) (not (looking-at "\\s-")))
+        (insert " ")))))
+
+(defun slime-copy-presentation-to-kill-ring (presentation start end buffer)
+  (let ((presentation-text
+         (with-current-buffer buffer
+           (buffer-substring start end))))
+    (kill-new presentation-text)
+    (message "Saved presentation \"%s\" to kill ring" presentation-text)))
+
+(defun slime-copy-presentation-at-mouse-to-kill-ring (event)
+  (interactive "e")
+  (multiple-value-bind (presentation start end buffer)
+      (slime-presentation-around-click event)
+    (slime-copy-presentation-to-kill-ring presentation start end buffer)))
+
+(defun slime-copy-presentation-at-point-to-kill-ring (point)
+  (interactive "d")
+  (multiple-value-bind (presentation start end)
+      (slime-presentation-around-or-before-point-or-error point)
+    (slime-copy-presentation-to-kill-ring presentation start end (current-buffer))))
+
+(defun slime-describe-presentation (presentation)
+  (slime-eval-describe
+   `(swank::describe-to-string
+     (swank:lookup-presented-object ',(slime-presentation-id presentation)))))
+
+(defun slime-describe-presentation-at-mouse (event)
+  (interactive "@e")
+  (multiple-value-bind (presentation) (slime-presentation-around-click event)
+    (slime-describe-presentation presentation)))
+
+(defun slime-describe-presentation-at-point (point)
+  (interactive "d")
+  (multiple-value-bind (presentation)
+      (slime-presentation-around-or-before-point-or-error point)
+    (slime-describe-presentation presentation)))
+
+(defun slime-pretty-print-presentation (presentation)
+  (slime-eval-describe
+   `(swank::swank-pprint
+     (cl:list
+      (swank:lookup-presented-object ',(slime-presentation-id presentation))))))
+
+(defun slime-pretty-print-presentation-at-mouse (event)
+  (interactive "@e")
+  (multiple-value-bind (presentation) (slime-presentation-around-click event)
+    (slime-pretty-print-presentation presentation)))
+
+(defun slime-pretty-print-presentation-at-point (point)
+  (interactive "d")
+  (multiple-value-bind (presentation)
+      (slime-presentation-around-or-before-point-or-error point)
+    (slime-pretty-print-presentation presentation)))
+
+(defun slime-mark-presentation (point)
+  (interactive "d")
+  (multiple-value-bind (presentation start end)
+      (slime-presentation-around-or-before-point-or-error point)
+    (goto-char start)
+    (push-mark end nil t)))
+
+(defun slime-previous-presentation (&optional arg)
+  "Move point to the beginning of the first presentation before point.
+With ARG, do this that many times.
+A negative argument means move forward instead."
+  (interactive "p")
+  (unless arg (setq arg 1))
+  (slime-next-presentation (- arg)))
+
+(defun slime-next-presentation (&optional arg)
+  "Move point to the beginning of the next presentation after point.
+With ARG, do this that many times.
+A negative argument means move backward instead."
+  (interactive "p")
+  (unless arg (setq arg 1))
+  (cond
+   ((plusp arg)
+    (dotimes (i arg)
+      ;; First skip outside the current surrounding presentation (if any)
+      (multiple-value-bind (presentation start end)
+	  (slime-presentation-around-point (point))
+	(when presentation
+	  (goto-char end)))
+      (let ((p (next-single-property-change (point) 'slime-repl-presentation)))
+	(unless p
+	  (error "No next presentation"))
+	(multiple-value-bind (presentation start end)
+	    (slime-presentation-around-or-before-point-or-error p)
+	  (goto-char start)))))
+   ((minusp arg)
+    (dotimes (i (- arg))
+      ;; First skip outside the current surrounding presentation (if any)
+      (multiple-value-bind (presentation start end)
+	  (slime-presentation-around-point (point))
+	(when presentation
+	  (goto-char start)))
+      (let ((p (previous-single-property-change (point) 'slime-repl-presentation)))
+	(unless p
+	  (error "No previous presentation"))
+	(multiple-value-bind (presentation start end)
+	    (slime-presentation-around-or-before-point-or-error p)
+	  (goto-char start)))))))
+
+(define-key  slime-presentation-map [mouse-2] 'slime-copy-or-inspect-presentation-at-mouse)
+(define-key  slime-presentation-map [mouse-3] 'slime-presentation-menu)
+
+(when (featurep 'xemacs)
+  (define-key  slime-presentation-map [button2] 'slime-copy-or-inspect-presentation-at-mouse)
+  (define-key  slime-presentation-map [button3] 'slime-presentation-menu))
+
+;; protocol for handling up a menu.
+;; 1. Send lisp message asking for menu choices for this object.
+;;    Get back list of strings.
+;; 2. Let used choose
+;; 3. Call back to execute menu choice, passing nth and string of choice
+
+(defun slime-menu-choices-for-presentation (presentation buffer from to choice-to-lambda)
+  "Return a menu for `presentation' at `from'--`to' in `buffer', suitable for `x-popup-menu'."
+  (let* ((what (slime-presentation-id presentation))
+         (choices (with-current-buffer buffer
+                    (slime-eval
+                     `(swank::menu-choices-for-presentation-id ',what)))))
+    (cl-labels ((savel (f) ;; IMPORTANT - xemacs can't handle lambdas in x-popup-menu. So give them a name
+                     (let ((sym (cl-gensym)))
+                       (setf (gethash sym choice-to-lambda) f)
+                       sym)))
+      (etypecase choices
+        (list
+         `(,(format "Presentation %s" (truncate-string-to-width
+                                       (slime-presentation-text presentation)
+                                       30 nil nil t))
+           (""
+            ("Find Definition" . ,(savel 'slime-M-.-presentation-at-mouse))
+            ("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse))
+            ("Describe" . ,(savel 'slime-describe-presentation-at-mouse))
+            ("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse))
+            ("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse-to-repl))
+            ("Copy to kill ring" . ,(savel 'slime-copy-presentation-at-mouse-to-kill-ring))
+            ,@(unless buffer-read-only
+                `(("Copy to point" . ,(savel 'slime-copy-presentation-at-mouse-to-point))))
+            ,@(let ((nchoice 0))
+                (mapcar
+                 (lambda (choice)
+                   (incf nchoice)
+                   (cons choice
+                         (savel `(lambda ()
+                                   (interactive)
+                                   (slime-eval
+                                    '(swank::execute-menu-choice-for-presentation-id
+                                      ',what ,nchoice ,(nth (1- nchoice) choices)))))))
+                 choices)))))
+        (symbol                           ; not-present
+         (with-current-buffer buffer
+           (slime-remove-presentation-properties from to presentation))
+         (sit-for 0)                      ; allow redisplay
+         `("Object no longer recorded"
+           ("sorry" . ,(if (featurep 'xemacs) nil '(nil)))))))))
+
+(defun slime-presentation-menu (event)
+  (interactive "e")
+  (let* ((point (if (featurep 'xemacs) (event-point event)
+                  (posn-point (event-end event))))
+         (window (if (featurep 'xemacs) (event-window event) (caadr event)))
+         (buffer (window-buffer window))
+         (choice-to-lambda (make-hash-table)))
+    (multiple-value-bind (presentation from to)
+        (with-current-buffer buffer
+          (slime-presentation-around-point point))
+      (unless presentation
+        (error "No presentation at event position"))
+      (let ((menu (slime-menu-choices-for-presentation
+                   presentation buffer from to choice-to-lambda)))
+        (let ((choice (x-popup-menu event menu)))
+          (when choice
+            (call-interactively (gethash choice choice-to-lambda))))))))
+
+(defun slime-presentation-expression (presentation)
+  "Return a string that contains a CL s-expression accessing
+the presented object."
+  (let ((id (slime-presentation-id presentation)))
+    (etypecase id
+      (number
+       ;; Make sure it works even if *read-base* is not 10.
+       (format "(swank:lookup-presented-object-or-lose %d.)" id))
+      (list
+       ;; for frame variables and inspector parts
+       (format "(swank:lookup-presented-object-or-lose '%s)" id)))))
+
+(defun slime-buffer-substring-with-reified-output (start end)
+  (let ((str-props (buffer-substring start end))
+        (str-no-props (buffer-substring-no-properties start end)))
+    (slime-reify-old-output str-props str-no-props)))
+
+(defun slime-reify-old-output (str-props str-no-props)
+  (let ((pos (slime-property-position 'slime-repl-presentation str-props)))
+    (if (null pos)
+        str-no-props
+      (multiple-value-bind (presentation start-pos end-pos whole-p)
+          (slime-presentation-around-point pos str-props)
+        (if (not presentation)
+            str-no-props
+          (concat (substring str-no-props 0 pos)
+                  ;; Eval in the reader so that we play nice with quote.
+                  ;; -luke (19/May/2005)
+                  "#." (slime-presentation-expression presentation)
+                  (slime-reify-old-output (substring str-props end-pos)
+                                          (substring str-no-props end-pos))))))))
+
+
+
+(defun slime-repl-grab-old-output (replace)
+  "Resend the old REPL output at point.
+If replace it non-nil the current input is replaced with the old
+output; otherwise the new input is appended."
+  (multiple-value-bind (presentation beg end)
+      (slime-presentation-around-or-before-point (point))
+    (slime-check-presentation beg end (current-buffer) presentation)
+    (let ((old-output (buffer-substring beg end))) ;;keep properties
+      ;; Append the old input or replace the current input
+      (cond (replace (goto-char slime-repl-input-start-mark))
+            (t (goto-char (point-max))
+               (unless (eq (char-before) ?\ )
+                 (insert " "))))
+      (delete-region (point) (point-max))
+      (let ((inhibit-read-only t))
+        (insert old-output)))))
+
+;;; Presentation-related key bindings, non-context menu
+
+(defvar slime-presentation-command-map nil
+  "Keymap for presentation-related commands. Bound to a prefix key.")
+
+(defvar slime-presentation-bindings
+  '((?i slime-inspect-presentation-at-point)
+    (?d slime-describe-presentation-at-point)
+    (?w slime-copy-presentation-at-point-to-kill-ring)
+    (?r slime-copy-presentation-at-point-to-repl)
+    (?p slime-previous-presentation)
+    (?n slime-next-presentation)
+    (?\  slime-mark-presentation)))
+
+(defun slime-presentation-init-keymaps ()
+  (slime-init-keymap 'slime-presentation-command-map nil t
+		     slime-presentation-bindings)
+  (define-key slime-presentation-command-map "\M-o" 'slime-clear-presentations)
+  ;; C-c C-v is the prefix for the presentation-command map.
+  (define-key slime-prefix-map "\C-v" slime-presentation-command-map))
+
+(defun slime-presentation-around-or-before-point-p ()
+  (multiple-value-bind (presentation beg end)
+      (slime-presentation-around-or-before-point (point))
+    presentation))
+
+(defvar slime-presentation-easy-menu
+  (let ((P '(slime-presentation-around-or-before-point-p)))
+    `("Presentations"
+      [ "Find Definition" slime-M-.-presentation-at-point ,P ]
+      [ "Inspect" slime-inspect-presentation-at-point ,P ]
+      [ "Describe" slime-describe-presentation-at-point ,P ]
+      [ "Pretty-print" slime-pretty-print-presentation-at-point ,P ]
+      [ "Copy to REPL" slime-copy-presentation-at-point-to-repl ,P ]
+      [ "Copy to kill ring" slime-copy-presentation-at-point-to-kill-ring ,P ]
+      [ "Mark" slime-mark-presentation ,P ]
+      "--"
+      [ "Previous presentation" slime-previous-presentation ]
+      [ "Next presentation" slime-next-presentation ]
+      "--"
+      [ "Clear all presentations" slime-clear-presentations ])))
+
+(defun slime-presentation-add-easy-menu ()
+  (easy-menu-define menubar-slime-presentation slime-mode-map "Presentations" slime-presentation-easy-menu)
+  (easy-menu-define menubar-slime-presentation slime-repl-mode-map "Presentations" slime-presentation-easy-menu)
+  (easy-menu-define menubar-slime-presentation sldb-mode-map "Presentations" slime-presentation-easy-menu)
+  (easy-menu-define menubar-slime-presentation slime-inspector-mode-map "Presentations" slime-presentation-easy-menu)
+  (easy-menu-add slime-presentation-easy-menu 'slime-mode-map)
+  (easy-menu-add slime-presentation-easy-menu 'slime-repl-mode-map)
+  (easy-menu-add slime-presentation-easy-menu 'sldb-mode-map)
+  (easy-menu-add slime-presentation-easy-menu 'slime-inspector-mode-map))
+
+;;; hook functions (hard to isolate stuff)
+
+(defun slime-dispatch-presentation-event (event)
+  (slime-dcase event
+    ((:presentation-start id &optional target)
+     (slime-mark-presentation-start id target)
+     t)
+    ((:presentation-end id &optional target)
+     (slime-mark-presentation-end id target)
+     t)
+    (t nil)))
+
+(defun slime-presentation-write-result (string)
+  (with-current-buffer (slime-output-buffer)
+    (let ((marker (slime-repl-output-target-marker :repl-result))
+          (saved-point (point-marker)))
+      (goto-char marker)
+      (slime-propertize-region `(face slime-repl-result-face
+                                      rear-nonsticky (face))
+        (insert string))
+      ;; Move the input-start marker after the REPL result.
+      (set-marker marker (point))
+      (set-marker slime-output-end (point))
+      ;; Restore point before insertion but only it if was farther
+      ;; than `marker'. Omitting this breaks REPL test
+      ;; `repl-type-ahead'.
+      (when (> saved-point (point))
+        (goto-char saved-point)))
+    (slime-repl-show-maximum-output)))
+
+(defun slime-presentation-write (string &optional target)
+  (case target
+    ((nil)                              ; Regular process output
+     (slime-repl-emit string))
+    (:repl-result
+     (slime-presentation-write-result string))
+    (t (slime-repl-emit-to-target string target))))
+
+(defun slime-presentation-current-input (&optional until-point-p)
+  "Return the current input as string.
+The input is the region from after the last prompt to the end of
+buffer. Presentations of old results are expanded into code."
+  (slime-buffer-substring-with-reified-output slime-repl-input-start-mark
+                                              (if until-point-p
+                                                  (point)
+                                                (point-max))))
+
+(defun slime-presentation-on-return-pressed (end-of-input)
+  (when (and (car (slime-presentation-around-or-before-point (point)))
+             (< (point) slime-repl-input-start-mark))
+    (slime-repl-grab-old-output end-of-input)
+    (slime-repl-recenter-if-needed)
+    t))
+
+(defun slime-presentation-bridge-insert (process output)
+  (slime-output-filter process (or output "")))
+
+(defun slime-presentation-on-stream-open (stream)
+  (install-bridge)
+  (setq bridge-insert-function #'slime-presentation-bridge-insert)
+  (setq bridge-destination-insert nil)
+  (setq bridge-source-insert nil)
+  (setq bridge-handlers
+	(list* '("<" . slime-mark-presentation-start-handler)
+	       '(">" . slime-mark-presentation-end-handler)
+	       bridge-handlers)))
+
+(defun slime-clear-presentations ()
+  "Forget all objects associated to SLIME presentations.
+This allows the garbage collector to remove these objects
+even on Common Lisp implementations without weak hash tables."
+  (interactive)
+  (slime-eval-async `(swank:clear-repl-results))
+  (unless (eql major-mode 'slime-repl-mode)
+    (slime-switch-to-output-buffer))
+  (slime-for-each-presentation-in-region 1 (1+ (buffer-size))
+					 (lambda (presentation from to whole-p)
+					   (slime-remove-presentation-properties from to
+										 presentation))))
+
+(defun slime-presentation-inspector-insert-ispec (ispec)
+  (if (stringp ispec)
+      (insert ispec)
+    (slime-dcase ispec
+      ((:value string id)
+       (slime-propertize-region
+           (list 'slime-part-number id
+                 'mouse-face 'highlight
+                 'face 'slime-inspector-value-face)
+         (slime-insert-presentation string `(:inspected-part ,id) t)))
+      ((:label string)
+       (insert (slime-inspector-fontify label string)))
+      ((:action string id)
+       (slime-insert-propertized (list 'slime-action-number id
+                                       'mouse-face 'highlight
+                                       'face 'slime-inspector-action-face)
+                                 string)))))
+
+(defun slime-presentation-sldb-insert-frame-variable-value (value frame index)
+  (slime-insert-presentation
+   (sldb-in-face local-value value)
+   `(:frame-var ,slime-current-thread ,(car frame) ,index) t))
+
+(defun slime-presentations-on-connected ()
+  (slime-eval-async `(swank:init-presentations)))
+
+(provide 'slime-presentations)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-quicklisp.el

@@ -0,0 +1,51 @@
+(require 'slime)
+(require 'cl-lib)
+
+;;; bits of the following taken from slime-asdf.el
+
+(define-slime-contrib slime-quicklisp
+  "Quicklisp support."
+  (:authors "Matthew Kennedy <burnsidemk@gmail.com>")
+  (:license "GPL")
+  (:slime-dependencies slime-repl)
+  (:swank-dependencies swank-quicklisp))
+
+;;; Utilities
+
+(defgroup slime-quicklisp nil
+  "Quicklisp support for Slime."
+  :prefix "slime-quicklisp-"
+  :group 'slime)
+
+(defvar slime-quicklisp-system-history nil
+  "History list for Quicklisp system names.")
+
+
+
+(defun slime-read-quicklisp-system-name (&optional prompt default-value)
+  "Read a Quick system name from the minibuffer, prompting with PROMPT."
+  (let* ((completion-ignore-case nil)
+         (prompt (or prompt "Quicklisp system"))
+         (quicklisp-system-names (slime-eval `(swank:list-quicklisp-systems)))
+         (prompt (concat prompt (if default-value
+                                    (format " (default `%s'): " default-value)
+                                  ": "))))
+    (completing-read prompt (slime-bogus-completion-alist quicklisp-system-names)
+                     nil nil nil
+                     'slime-quicklisp-system-history default-value)))
+
+(defun slime-quicklisp-quickload (system)
+  "Load a Quicklisp system."
+  (slime-save-some-lisp-buffers)
+  (slime-display-output-buffer)
+  (slime-repl-shortcut-eval-async `(ql:quickload ,system)))
+
+;;; REPL shortcuts
+
+(defslime-repl-shortcut slime-repl-quicklisp-quickload ("quicklisp-quickload" "ql")
+  (:handler (lambda ()
+              (interactive)
+              (slime-quicklisp-quickload (slime-read-quicklisp-system-name))))
+  (:one-liner "Load a system known to Quicklisp."))
+
+(provide 'slime-quicklisp)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-references.el

@@ -0,0 +1,156 @@
+(require 'slime)
+(require 'advice)
+(require 'slime-compiler-notes-tree) ; FIXME: actually only uses the tree bits, so that should be a library.
+
+(define-slime-contrib slime-references
+  "Clickable references to documentation (SBCL only)."
+  (:authors "Christophe Rhodes  <csr21@cantab.net>"
+            "Luke Gorrie  <luke@bluetail.com>"
+            "Tobias C. Rittweiler <tcr@freebits.de>")
+  (:license "GPL")
+  (:on-load
+   (ad-enable-advice 'slime-note.message 'after 'slime-note.message+references)
+   (ad-activate 'slime-note.message)
+   (setq slime-tree-printer 'slime-tree-print-with-references)
+   (add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))
+  (:on-unload
+   (ad-disable-advice 'slime-note.message 'after 'slime-note.message+references)
+   (ad-deactivate 'slime-note.message)
+   (setq slime-tree-printer 'slime-tree-default-printer)
+   (remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)))
+
+(defcustom slime-sbcl-manual-root "http://www.sbcl.org/manual/"
+  "*The base URL of the SBCL manual, for documentation lookup."
+  :type '(choice (string :tag "HTML Documentation")
+                 (const :tag "Info Documentation" :info))
+  :group 'slime-mode)
+
+(defface sldb-reference-face
+  (list (list t '(:underline t)))
+  "Face for references."
+  :group 'slime-debugger)
+
+
+;;;;; SBCL-style references
+
+(defvar slime-references-local-keymap
+  (let ((map (make-sparse-keymap "local keymap for slime references")))
+    (define-key map [mouse-2] 'slime-lookup-reference-at-mouse)
+    (define-key map [return] 'slime-lookup-reference-at-point)
+    map))
+
+(defun slime-reference-properties (reference)
+  "Return the properties for a reference.
+Only add clickability to properties we actually know how to lookup."
+  (cl-destructuring-bind (where type what) reference
+    (if (or (and (eq where :sbcl) (eq type :node))
+            (and (eq where :ansi-cl)
+                 (memq type '(:function :special-operator :macro
+                                        :type :system-class
+                                        :section :glossary :issue))))
+        `(slime-reference ,reference
+                          font-lock-face sldb-reference-face
+                          follow-link t
+                          mouse-face highlight
+                          help-echo "mouse-2: visit documentation."
+                          keymap ,slime-references-local-keymap))))
+
+(defun slime-insert-reference (reference)
+  "Insert documentation reference from a condition.
+See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
+  (cl-destructuring-bind (where type what) reference
+    (insert "\n" (slime-format-reference-source where) ", ")
+    (slime-insert-propertized (slime-reference-properties reference)
+                              (slime-format-reference-node what))
+    (insert (format " [%s]" type))))
+
+(defun slime-insert-references (references)
+  (when references
+    (insert "\nSee also:")
+    (slime-with-rigid-indentation 2
+      (mapc #'slime-insert-reference references))))
+
+(defun slime-format-reference-source (where)
+  (cl-case where
+    (:amop    "The Art of the Metaobject Protocol")
+    (:ansi-cl "Common Lisp Hyperspec")
+    (:sbcl    "SBCL Manual")
+    (t        (format "%S" where))))
+
+(defun slime-format-reference-node (what)
+  (if (listp what)
+      (mapconcat #'prin1-to-string what ".")
+    what))
+
+(defun slime-lookup-reference-at-point ()
+  "Browse the documentation reference at point."
+  (interactive)
+  (let ((refs (get-text-property (point) 'slime-reference)))
+    (if (null refs)
+        (error "No references at point")
+      (cl-destructuring-bind (where type what) refs
+        (cl-case where
+          (:ansi-cl
+           (cl-case type
+             (:section
+              (browse-url (funcall common-lisp-hyperspec-section-fun what)))
+             (:glossary
+              (browse-url (funcall common-lisp-hyperspec-glossary-function what)))
+             (:issue
+              (browse-url (common-lisp-issuex what)))
+             (:special-operator
+              (browse-url (common-lisp-special-operator (downcase name))))
+             (t
+              (hyperspec-lookup what))))
+          (t
+           (case slime-sbcl-manual-root
+             (:info
+              (info (format "(sbcl)%s" what)))
+             (t
+              (browse-url
+               (format "%s#%s" slime-sbcl-manual-root
+                       (subst-char-in-string ?\  ?\- what)))))))))))
+
+(defun slime-lookup-reference-at-mouse (event)
+  "Invoke the action pointed at by the mouse."
+  (interactive "e")
+  (cl-destructuring-bind (mouse-1 (w pos . _) . _) event
+    (save-excursion
+      (goto-char pos)
+      (slime-lookup-reference-at-point))))
+
+;;;;; Hook into *SLIME COMPILATION*
+
+(defun slime-note.references (note)
+  (plist-get note :references))
+
+;;; FIXME: `compilation-mode' will swallow the `mouse-face'
+;;; etc. properties.
+(defadvice slime-note.message (after slime-note.message+references)
+  (setq ad-return-value
+        (concat ad-return-value
+                (with-temp-buffer
+                  (slime-insert-references
+                   (slime-note.references (ad-get-arg 0)))
+                  (buffer-string)))))
+
+;;;;; Hook into slime-compiler-notes-tree
+
+(defun slime-tree-print-with-references (tree)
+  ;; for SBCL-style references
+  (slime-tree-default-printer tree)
+  (let ((note (plist-get (slime-tree.plist tree) 'note)))
+    (when note
+      (let ((references (slime-note.references note)))
+        (when references
+          (terpri (current-buffer))
+          (slime-insert-references references))))))
+
+;;;;; Hook into SLDB
+
+(defun sldb-maybe-insert-references (extra)
+  (slime-dcase extra
+    ((:references references) (slime-insert-references references) t)
+    (t nil)))
+
+(provide 'slime-references)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-sbcl-exts.el

@@ -0,0 +1,34 @@
+(require 'slime)
+(require 'cl-lib)
+
+(define-slime-contrib slime-sbcl-exts
+  "Misc extensions for SBCL"
+  (:authors "Tobias C. Rittweiler <tcr@freebits.de>")
+  (:license "GPL")
+  (:slime-dependencies slime-references)
+  (:swank-dependencies swank-sbcl-exts))
+
+(defun slime-sbcl-bug-at-point ()
+  (save-excursion
+    (save-match-data
+      (unless (looking-at "#[0-9]\\{6\\}")
+        (search-backward-regexp "#\\<" (line-beginning-position) t))
+      (when (looking-at "#[0-9]\\{6\\}")
+        (buffer-substring-no-properties (match-beginning 0) (match-end 0))))))
+
+(defun slime-read-sbcl-bug (prompt &optional query)
+  "Either read a sbcl bug or choose the one at point.
+The user is prompted if a prefix argument is in effect, if there is no
+symbol at point, or if QUERY is non-nil."
+  (let ((bug (slime-sbcl-bug-at-point)))
+    (cond ((or current-prefix-arg query (not bug))
+           (slime-read-from-minibuffer prompt bug))
+          (t bug))))
+
+(defun slime-visit-sbcl-bug (bug)
+  "Visit the Launchpad site that describes `bug' (#nnnnnn)."
+  (interactive (list (slime-read-sbcl-bug "Bug number (#nnnnnn): ")))
+  (browse-url (format "http://bugs.launchpad.net/sbcl/+bug/%s" 
+                      (substring bug 1))))
+
+(provide 'slime-sbcl-exts)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-scheme.el

@@ -0,0 +1,40 @@
+;;; slime-scheme.el --- Support Scheme programs running under Common Lisp
+;;
+;; Authors: Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>
+;; 
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add this to your .emacs: 
+;;
+;;   (add-to-list 'load-path "<directory-of-this-file>")
+;;   (add-hook 'slime-load-hook (lambda () (require 'slime-scheme)))
+;;
+(eval-and-compile
+  (require 'slime))
+
+(defun slime-scheme-mode-hook ()
+  (slime-mode 1))
+
+(defun slime-scheme-indentation-update (symbol indent packages)
+  ;; Does the symbol have an indentation value that we set?
+  (when (equal (get symbol 'scheme-indent-function)
+	       (get symbol 'slime-scheme-indent))
+    (put symbol 'slime-scheme-indent indent)
+    (put symbol 'scheme-indent-function indent)))
+
+
+;;; Initialization
+
+(defun slime-scheme-init ()
+  (add-hook 'scheme-mode-hook 'slime-scheme-mode-hook)
+  (add-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update)
+  (add-to-list 'slime-lisp-modes 'scheme-mode))
+
+(defun slime-scheme-unload ()
+  (remove-hook 'scheme-mode-hook 'slime-scheme-mode-hook)
+  (remove-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update)
+  (setq slime-lisp-modes (remove 'scheme-mode slime-lisp-modes)))
+
+(provide 'slime-scheme)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-scratch.el

@@ -0,0 +1,48 @@
+;;; slime-scratch.el
+
+(require 'slime)
+(require 'cl-lib)
+
+(define-slime-contrib slime-scratch
+  "Imitate Emacs' *scratch* buffer"
+  (:authors "Helmut Eller  <heller@common-lisp.net>")
+  (:license "GPL")
+  (:on-load
+   (def-slime-selector-method ?s "*slime-scratch* buffer."
+     (slime-scratch-buffer))))
+
+
+;;; Code
+
+(defvar slime-scratch-mode-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map lisp-mode-map)
+    map))
+
+(defun slime-scratch ()
+  (interactive)
+  (slime-switch-to-scratch-buffer))
+
+(defun slime-switch-to-scratch-buffer ()
+  (set-buffer (slime-scratch-buffer))
+  (unless (eq (current-buffer) (window-buffer))
+    (pop-to-buffer (current-buffer) t)))
+
+(defvar slime-scratch-file nil)
+
+(defun slime-scratch-buffer ()
+  "Return the scratch buffer, create it if necessary."
+  (or (get-buffer (slime-buffer-name :scratch))
+      (with-current-buffer (if slime-scratch-file
+                               (find-file slime-scratch-file)
+                             (get-buffer-create (slime-buffer-name :scratch)))
+        (rename-buffer (slime-buffer-name :scratch))
+	(lisp-mode)
+	(use-local-map slime-scratch-mode-map)
+	(slime-mode t)
+	(current-buffer))))
+
+(slime-define-keys slime-scratch-mode-map
+  ("\C-j" 'slime-eval-print-last-expression))
+
+(provide 'slime-scratch)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-snapshot.el

@@ -0,0 +1,34 @@
+(eval-and-compile
+  (require 'slime))
+
+(define-slime-contrib slime-snapshot
+  "Save&restore memory images without disconnecting"
+  (:authors "Helmut Eller <heller@common-lisp.net>")
+  (:license "GPL v3")
+  (:swank-dependencies swank-snapshot))
+
+(defun slime-snapshot (filename &optional background)
+  "Save a memory image to the file FILENAME."
+  (interactive (list (read-file-name "Image file: ")
+		     current-prefix-arg))
+  (let ((file (expand-file-name filename)))
+    (when (and (file-exists-p file)
+	       (not (yes-or-no-p (format "File exists %s.  Overwrite it? " 
+					 filename))))
+      (signal 'quit nil))
+    (slime-eval-with-transcript
+     `(,(if background
+	    'swank-snapshot:background-save-snapshot
+	  'swank-snapshot:save-snapshot)
+       ,file))))
+
+(defun slime-restore (filename)
+  "Restore a memory image stored in file FILENAME."
+  (interactive (list (read-file-name "Image file: ")))
+  ;; bypass event dispatcher because we don't expect a reply. FIXME.
+  (slime-net-send `(:emacs-rex (swank-snapshot:restore-snapshot 
+				,(expand-file-name filename))
+			       nil t nil)
+		  (slime-connection)))
+
+(provide 'slime-snapshot)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-sprof.el

@@ -0,0 +1,224 @@
+(require 'slime)
+(require 'cl-lib)
+(eval-when-compile (require 'cl)) ; lexical-let*
+
+(define-slime-contrib slime-sprof
+  "Integration with SBCL's sb-sprof."
+  (:authors "Juho Snellman"
+            "Stas Boukarev")
+  (:license "MIT")
+  (:swank-dependencies swank-sprof)
+  (:on-load
+   (let ((C '(and (slime-connected-p)
+              (equal (slime-lisp-implementation-type) "SBCL"))))
+     (setf (cdr (last (assoc "Profiling" slime-easy-menu)))
+           `("--"
+             [ "Start sb-sprof"  slime-sprof-start ,C ]
+             [ "Stop sb-sprof"   slime-sprof-stop ,C ]
+             [ "Report sb-sprof" slime-sprof-report ,C ])))))
+
+(defvar slime-sprof-exclude-swank nil
+  "*Display swank functions in the report.")
+
+(define-derived-mode slime-sprof-browser-mode fundamental-mode
+  "slprof"
+  "Mode for browsing profiler data\
+\\<slime-sprof-browser-mode-map>\
+\\{slime-sprof-browser-mode-map}"
+  :syntax-table lisp-mode-syntax-table
+  (setq buffer-read-only t))
+
+(set-keymap-parent slime-sprof-browser-mode-map slime-parent-map)
+
+(slime-define-keys slime-sprof-browser-mode-map
+  ("h" 'describe-mode)
+  ("d" 'slime-sprof-browser-disassemble-function)
+  ("g" 'slime-sprof-browser-go-to)
+  ("v" 'slime-sprof-browser-view-source)
+  ("s" 'slime-sprof-toggle-swank-exclusion)
+  ((kbd "RET") 'slime-sprof-browser-toggle))
+
+;; Start / stop profiling
+
+(cl-defun slime-sprof-start (&optional (mode :cpu))
+  (interactive)
+  (slime-eval `(swank:swank-sprof-start :mode ,mode)))
+
+(defun slime-sprof-start-alloc ()
+  (interactive)
+  (slime-sprof-start :alloc))
+
+(defun slime-sprof-start-time ()
+  (interactive)
+  (slime-sprof-start :time))
+
+(defun slime-sprof-stop ()
+  (interactive)
+  (slime-eval `(swank:swank-sprof-stop)))
+
+;; Reporting
+
+(defun slime-sprof-format (graph)
+  (with-current-buffer (slime-buffer-name :sprof)
+    (let ((inhibit-read-only t))
+      (erase-buffer)
+      (insert (format "%4s %-54s %6s %6s %6s\n"
+                      "Rank"
+                      "Name"
+                      "Self%"
+                      "Cumul%"
+                      "Total%"))
+      (dolist (data graph)
+        (slime-sprof-browser-insert-line data 54))))
+  (forward-line 2))
+
+(cl-defun slime-sprof-update (&optional (exclude-swank slime-sprof-exclude-swank))
+  (slime-eval-async `(swank:swank-sprof-get-call-graph
+                      :exclude-swank ,exclude-swank)
+    'slime-sprof-format))
+
+(defalias 'slime-sprof-browser 'slime-sprof-report)
+
+(defun slime-sprof-report ()
+  (interactive)
+  (slime-with-popup-buffer ((slime-buffer-name :sprof)
+                            :connection t
+                            :select t
+                            :mode 'slime-sprof-browser-mode)
+    (slime-sprof-update)))
+
+(defun slime-sprof-toggle-swank-exclusion ()
+  (interactive)
+  (setq slime-sprof-exclude-swank
+        (not slime-sprof-exclude-swank))
+  (slime-sprof-update))
+
+(defun slime-sprof-browser-insert-line (data name-length)
+  (cl-destructuring-bind (index name self cumul total)
+      data
+    (if index
+        (insert (format "%-4d " index))
+      (insert "     "))
+    (slime-insert-propertized
+     (slime-sprof-browser-name-properties)
+     (format (format "%%-%ds " name-length)
+             (slime-sprof-abbreviate-name name name-length)))
+    (insert (format "%6.2f " self))
+    (when cumul
+      (insert (format "%6.2f " cumul))
+      (when total
+        (insert (format "%6.2f" total))))
+    (when index
+      (slime-sprof-browser-add-line-text-properties
+       `(profile-index ,index expanded nil)))
+    (insert "\n")))
+
+(defun slime-sprof-abbreviate-name (name max-length)
+  (cl-subseq name 0 (min (length name) max-length)))
+
+;; Expanding / collapsing
+
+(defun slime-sprof-browser-toggle ()
+  (interactive)
+  (let ((index (get-text-property (point) 'profile-index)))
+    (when index
+      (save-excursion
+        (if (slime-sprof-browser-line-expanded-p)
+            (slime-sprof-browser-collapse)
+            (slime-sprof-browser-expand))))))
+
+(defun slime-sprof-browser-collapse ()
+  (let ((inhibit-read-only t))
+    (slime-sprof-browser-add-line-text-properties '(expanded nil))
+    (forward-line)
+    (cl-loop until (or (eobp)
+                       (get-text-property (point) 'profile-index))
+             do
+             (delete-region (point-at-bol) (point-at-eol))
+             (unless (eobp)
+               (delete-char 1)))))
+
+(defun slime-sprof-browser-expand ()
+  (lexical-let* ((buffer (current-buffer))
+                 (point (point))
+                 (index (get-text-property point 'profile-index)))
+    (slime-eval-async `(swank:swank-sprof-expand-node ,index)
+                      (lambda (data)
+                        (with-current-buffer buffer
+                          (save-excursion 
+                            (destructuring-bind (&key callers calls)
+                                data
+                              (slime-sprof-browser-add-expansion callers
+                                                                   "Callers"
+                                                                   0)
+                              (slime-sprof-browser-add-expansion calls
+                                                                   "Calls"
+                                                                   0))))))))
+
+(defun slime-sprof-browser-add-expansion (data type nesting)
+  (when data
+    (let ((inhibit-read-only t))
+      (slime-sprof-browser-add-line-text-properties '(expanded t))
+      (end-of-line)
+      (insert (format "\n     %s" type))
+      (dolist (node data)
+        (cl-destructuring-bind (index name cumul) node
+          (insert (format (format "\n%%%ds" (+ 7 (* 2 nesting))) ""))
+          (slime-insert-propertized
+           (slime-sprof-browser-name-properties)
+           (let ((len (- 59 (* 2 nesting))))
+             (format (format "%%-%ds " len)
+                     (slime-sprof-abbreviate-name name len))))
+          (slime-sprof-browser-add-line-text-properties
+           `(profile-sub-index ,index))
+          (insert (format "%6.2f" cumul)))))))
+
+(defun slime-sprof-browser-line-expanded-p ()
+  (get-text-property (point) 'expanded))
+
+(defun slime-sprof-browser-add-line-text-properties (properties)
+  (add-text-properties (point-at-bol)
+                       (point-at-eol)
+                       properties))
+
+(defun slime-sprof-browser-name-properties ()
+  '(face sldb-restart-number-face))
+
+;; "Go to function"
+
+(defun slime-sprof-browser-go-to ()                                           
+  (interactive)
+  (let ((sub-index (get-text-property (point) 'profile-sub-index)))
+    (when sub-index
+      (let ((pos (text-property-any
+                  (point-min) (point-max) 'profile-index sub-index)))
+        (when pos (goto-char pos))))))
+
+;; Disassembly
+
+(defun slime-sprof-browser-disassemble-function ()
+  (interactive)
+  (let ((index (or (get-text-property (point) 'profile-index)
+                   (get-text-property (point) 'profile-sub-index))))
+    (when index
+      (slime-eval-describe `(swank:swank-sprof-disassemble
+                             ,index)))))
+
+;; View source
+
+(defun slime-sprof-browser-view-source ()
+  (interactive)
+  (let ((index (or (get-text-property (point) 'profile-index)
+                   (get-text-property (point) 'profile-sub-index))))
+    (when index
+      (slime-eval-async
+       `(swank:swank-sprof-source-location ,index)
+       (lambda (source-location)
+         (slime-dcase source-location
+           ((:error message)
+            (message "%s" message)
+            (ding))
+           (t
+            (slime-show-source-location source-location))))))))
+
+(provide 'slime-sprof)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-trace-dialog.el

@@ -0,0 +1,837 @@
+;;; -*- coding: utf-8; lexical-binding: t -*-
+;;;
+;;; slime-trace-dialog.el -- a navigable dialog of inspectable trace entries
+;;;
+;;; TODO: implement better wrap interface for sbcl method, labels and such
+;;; TODO: backtrace printing is very slow
+;;;
+(require 'slime)
+(require 'slime-parse)
+(require 'slime-repl)
+(require 'cl-lib)
+
+(define-slime-contrib slime-trace-dialog
+  "Provide an interfactive trace dialog buffer for managing and
+inspecting details of traced functions. Invoke this dialog with C-c T."
+  (:authors "João Távora <joaotavora@gmail.com>")
+  (:license "GPL")
+  (:swank-dependencies swank-trace-dialog)
+  (:on-load (add-hook 'slime-mode-hook 'slime-trace-dialog-enable)
+            (add-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable))
+  (:on-unload (remove-hook 'slime-mode-hook 'slime-trace-dialog-enable)
+              (remove-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable)))
+
+
+;;;; Variables
+;;;
+(defvar slime-trace-dialog-flash t
+  "Non-nil means flash the updated region of the SLIME Trace Dialog. ")
+
+(defvar slime-trace-dialog--specs-overlay nil)
+
+(defvar slime-trace-dialog--progress-overlay nil)
+
+(defvar slime-trace-dialog--tree-overlay nil)
+
+(defvar slime-trace-dialog--collapse-chars (cons "-" "+"))
+
+
+;;;; Local trace entry model
+(defvar slime-trace-dialog--traces nil)
+
+(cl-defstruct (slime-trace-dialog--trace
+               (:constructor slime-trace-dialog--make-trace))
+  id
+  parent
+  spec
+  args
+  retlist
+  depth
+  beg
+  end
+  collapse-button-marker
+  summary-beg
+  children-end
+  collapsed-p)
+
+(defun slime-trace-dialog--find-trace (id)
+  (gethash id slime-trace-dialog--traces))
+
+
+;;;; Modes and mode maps
+;;;
+(defvar slime-trace-dialog-mode-map
+  (let ((map (make-sparse-keymap))
+        (remaps '((slime-inspector-operate-on-point . nil)
+                  (slime-inspector-operate-on-click . nil)
+                  (slime-inspector-reinspect
+                   . slime-trace-dialog-fetch-status)
+                  (slime-inspector-next-inspectable-object
+                   . slime-trace-dialog-next-button)
+                  (slime-inspector-previous-inspectable-object
+                   . slime-trace-dialog-prev-button))))
+    (set-keymap-parent map slime-inspector-mode-map)
+    (cl-loop for (old . new) in remaps
+             do (substitute-key-definition old new map))
+    (set-keymap-parent map slime-parent-map)
+    (define-key map (kbd "G") 'slime-trace-dialog-fetch-traces)
+    (define-key map (kbd "C-k") 'slime-trace-dialog-clear-fetched-traces)
+    (define-key map (kbd "g") 'slime-trace-dialog-fetch-status)
+    (define-key map (kbd "M-RET") 'slime-trace-dialog-copy-down-to-repl)
+    (define-key map (kbd "q") 'quit-window)
+    map))
+
+(define-derived-mode slime-trace-dialog-mode fundamental-mode
+  "SLIME Trace Dialog" "Mode for controlling SLIME's Trace Dialog"
+  (set-syntax-table lisp-mode-syntax-table)
+  (read-only-mode 1)
+  (add-to-list (make-local-variable 'slime-trace-dialog-after-toggle-hook)
+               'slime-trace-dialog-fetch-status))
+
+(define-derived-mode slime-trace-dialog--detail-mode slime-inspector-mode
+  "SLIME Trace Detail"
+  "Mode for viewing a particular trace from SLIME's Trace Dialog")
+
+(setq slime-trace-dialog--detail-mode-map
+      (let ((map (make-sparse-keymap))
+            (remaps '((slime-inspector-next-inspectable-object
+                       . slime-trace-dialog-next-button)
+                      (slime-inspector-previous-inspectable-object
+                       . slime-trace-dialog-prev-button))))
+        (set-keymap-parent map slime-trace-dialog-mode-map)
+        (cl-loop for (old . new) in remaps
+                 do (substitute-key-definition old new map))
+        map))
+
+(defvar slime-trace-dialog-minor-mode-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map (kbd "C-c T") 'slime-trace-dialog)
+    (define-key map (kbd "C-c M-t") 'slime-trace-dialog-toggle-trace)
+    map))
+
+(define-minor-mode slime-trace-dialog-minor-mode
+  "Add keybindings for accessing SLIME's Trace Dialog.")
+
+(defun slime-trace-dialog-enable ()
+  (slime-trace-dialog-minor-mode 1))
+
+(easy-menu-define slime-trace-dialog--menubar (list slime-trace-dialog-minor-mode-map
+                                                    slime-trace-dialog-mode-map)
+  "A menu for accessing some features of SLIME's Trace Dialog"
+  (let* ((in-dialog '(eq major-mode 'slime-trace-dialog-mode))
+         (dialog-live `(and ,in-dialog
+                            (memq slime-buffer-connection slime-net-processes)))
+         (connected '(slime-connected-p)))
+    `("Trace"
+      ["Toggle trace" slime-trace-dialog-toggle-trace ,connected]
+      ["Trace complex spec" slime-trace-dialog-toggle-complex-trace ,connected]
+      ["Open Trace dialog" slime-trace-dialog (and ,connected (not ,in-dialog))]
+      "--"
+      [ "Refresh traces and progress" slime-trace-dialog-fetch-status ,dialog-live]
+      [ "Fetch next batch" slime-trace-dialog-fetch-traces ,dialog-live]
+      [ "Clear all fetched traces" slime-trace-dialog-clear-fetched-traces ,dialog-live]
+      [ "Toggle details" slime-trace-dialog-hide-details-mode ,in-dialog]
+      [ "Toggle autofollow" slime-trace-dialog-autofollow-mode ,in-dialog])))
+
+(define-minor-mode slime-trace-dialog-hide-details-mode
+  "Hide details in `slime-trace-dialog-mode'"
+  nil " Brief"    
+  :group 'slime-trace-dialog
+  (unless (derived-mode-p 'slime-trace-dialog-mode)
+    (error "Not a SLIME Trace Dialog buffer"))
+  (slime-trace-dialog--set-hide-details-mode))
+
+(define-minor-mode slime-trace-dialog-autofollow-mode
+  "Automatically open buffers with trace details from `slime-trace-dialog-mode'"
+  nil " Autofollow"
+  :group 'slime-trace-dialog
+  (unless (derived-mode-p 'slime-trace-dialog-mode)
+    (error "Not a SLIME Trace Dialog buffer")))
+
+
+;;;; Helper functions
+;;;
+(defun slime-trace-dialog--call-refreshing (buffer
+                                            overlay
+                                            dont-erase
+                                            recover-point-p
+                                            fn)
+  (with-current-buffer buffer
+    (let ((inhibit-point-motion-hooks t)
+          (inhibit-read-only t)
+          (saved (point)))
+      (save-restriction
+        (when overlay
+          (narrow-to-region (overlay-start overlay)
+                            (overlay-end overlay)))
+        (unwind-protect
+            (if dont-erase
+                (goto-char (point-max))
+              (delete-region (point-min) (point-max)))
+          (funcall fn)
+          (when recover-point-p
+            (goto-char saved)))
+        (when slime-trace-dialog-flash
+          (slime-flash-region (point-min) (point-max)))))
+    buffer))
+
+(cl-defmacro slime-trace-dialog--refresh ((&key
+                                           overlay
+                                           dont-erase
+                                           recover-point-p
+                                           buffer)
+                                          &rest body)
+  (declare (indent 1)
+           (debug (sexp &rest form)))
+  `(slime-trace-dialog--call-refreshing ,(or buffer
+                                             `(current-buffer))
+                                        ,overlay
+                                        ,dont-erase
+                                        ,recover-point-p
+                                        #'(lambda () ,@body)))
+
+(defmacro slime-trace-dialog--insert-and-overlay (string overlay)
+  `(save-restriction
+     (let ((inhibit-read-only t))
+       (narrow-to-region (point) (point))
+       (insert ,string "\n")
+       (set (make-local-variable ',overlay)
+            (let ((overlay (make-overlay (point-min)
+                                         (point-max)
+                                         (current-buffer)
+                                         nil
+                                         t)))
+              (move-overlay overlay (overlay-start overlay)
+                            (1- (overlay-end overlay)))
+              ;; (overlay-put overlay 'face '(:background "darkslategrey"))
+              overlay)))))
+
+(defun slime-trace-dialog--buffer-name ()
+  (format "*traces for %s*"
+          (slime-connection-name slime-default-connection)))
+
+(defun slime-trace-dialog--live-dialog (&optional buffer-or-name)
+  (let ((buffer-or-name (or buffer-or-name
+                            (slime-trace-dialog--buffer-name))))
+    (and (buffer-live-p (get-buffer buffer-or-name))
+       (with-current-buffer buffer-or-name
+         (memq slime-buffer-connection slime-net-processes))
+       buffer-or-name)))
+
+(defun slime-trace-dialog--ensure-buffer ()
+  (let ((name (slime-trace-dialog--buffer-name)))
+    (or (slime-trace-dialog--live-dialog name)
+        (with-current-buffer (get-buffer-create name)
+          (let ((inhibit-read-only t))
+            (erase-buffer))
+          (slime-trace-dialog-mode)
+          (save-excursion
+            (buffer-disable-undo)
+            (slime-trace-dialog--insert-and-overlay
+             "[waiting for the traced specs to be available]"
+             slime-trace-dialog--specs-overlay)
+            (slime-trace-dialog--insert-and-overlay
+             "[waiting for some info on trace download progress ]"
+             slime-trace-dialog--progress-overlay)
+            (slime-trace-dialog--insert-and-overlay
+             "[waiting for the actual traces to be available]"
+             slime-trace-dialog--tree-overlay)
+            (current-buffer))
+          (setq slime-buffer-connection slime-default-connection)
+          (current-buffer)))))
+
+(defun slime-trace-dialog--make-autofollow-fn (id)
+  (let ((requested nil))
+    #'(lambda (_before after)
+        (let ((inhibit-point-motion-hooks t)
+              (id-after (get-text-property after 'slime-trace-dialog--id)))
+          (when (and (= after (point))
+                     slime-trace-dialog-autofollow-mode
+                     id-after
+                     (= id-after id)
+                     (not requested))
+            (setq requested t)
+            (slime-eval-async `(swank-trace-dialog:report-trace-detail
+                                ,id-after)
+              #'(lambda (detail)
+                  (setq requested nil)
+                  (when detail
+                    (let ((inhibit-point-motion-hooks t))
+                      (slime-trace-dialog--open-detail detail
+                                                       'no-pop))))))))))
+
+(defun slime-trace-dialog--set-collapsed (collapsed-p trace button)
+  (save-excursion
+    (setf (slime-trace-dialog--trace-collapsed-p trace) collapsed-p)
+    (slime-trace-dialog--go-replace-char-at
+     button
+     (if collapsed-p
+         (cdr slime-trace-dialog--collapse-chars)
+       (car slime-trace-dialog--collapse-chars)))
+    (slime-trace-dialog--hide-unhide
+     (slime-trace-dialog--trace-summary-beg trace)
+     (slime-trace-dialog--trace-end trace)
+     (if collapsed-p 1 -1))
+    (slime-trace-dialog--hide-unhide
+     (slime-trace-dialog--trace-end trace)
+     (slime-trace-dialog--trace-children-end trace)
+     (if collapsed-p 1 -1))))
+
+(defun slime-trace-dialog--hide-unhide (start-pos end-pos delta)
+  (cl-loop with inhibit-read-only = t
+           for pos = start-pos then next
+           for next = (next-single-property-change
+                       pos
+                       'slime-trace-dialog--hidden-level
+                       nil
+                       end-pos)
+           for hidden-level = (+ (or (get-text-property
+                                      pos
+                                      'slime-trace-dialog--hidden-level)
+                                     0)
+                                 delta)
+           do (add-text-properties pos next
+                                   (list 'slime-trace-dialog--hidden-level
+                                         hidden-level
+                                         'invisible
+                                         (cl-plusp hidden-level)))
+           while (< next end-pos)))
+
+(defun slime-trace-dialog--set-hide-details-mode ()
+  (cl-loop for trace being the hash-values of slime-trace-dialog--traces
+           do (slime-trace-dialog--hide-unhide
+               (slime-trace-dialog--trace-summary-beg trace)
+               (slime-trace-dialog--trace-end trace)
+               (if slime-trace-dialog-hide-details-mode 1 -1))))
+
+(defun slime-trace-dialog--format-part (part-id part-text trace-id type)
+  (slime-trace-dialog--button
+   (format "%s" part-text)
+   #'(lambda (_button)
+       (slime-eval-async
+           `(swank-trace-dialog:inspect-trace-part ,trace-id ,part-id ,type)
+         #'slime-open-inspector))
+   'mouse-face 'highlight
+   'slime-trace-dialog--part-id part-id
+   'slime-trace-dialog--type type
+   'face 'slime-inspector-value-face))
+
+(defun slime-trace-dialog--format-trace-entry (id external)
+  (slime-trace-dialog--button
+   (format "%s" external)
+   #'(lambda (_button)
+       (slime-eval-async
+           `(swank::inspect-object (swank-trace-dialog::find-trace ,id))
+         #'slime-open-inspector))
+   'face 'slime-inspector-value-face))
+
+(defun slime-trace-dialog--format (fmt-string &rest args)
+  (let* ((string (apply #'format fmt-string args))
+         (indent (make-string (max 2
+                                   (- 50 (length string))) ? )))
+    (format "%s%s" string indent)))
+
+(defun slime-trace-dialog--button (title lambda &rest props)
+  (let ((string (format "%s" title)))
+    (apply #'make-text-button string nil
+           'action     #'(lambda (button)
+                           (funcall lambda button))
+           'mouse-face 'highlight
+           'face       'slime-inspector-action-face
+           props)
+    string))
+
+(defun slime-trace-dialog--call-maintaining-properties (pos fn)
+  (save-excursion
+    (goto-char pos)
+    (let* ((saved-props (text-properties-at pos))
+           (saved-point (point))
+           (inhibit-read-only t)
+           (inhibit-point-motion-hooks t))
+      (funcall fn)
+      (add-text-properties saved-point (point) saved-props)
+      (if (markerp pos) (set-marker pos saved-point)))))
+
+(cl-defmacro slime-trace-dialog--maintaining-properties (pos
+                                                         &body body)
+  (declare (indent 1))
+  `(slime-trace-dialog--call-maintaining-properties ,pos #'(lambda () ,@body)))
+
+(defun slime-trace-dialog--go-replace-char-at (pos char)
+  (slime-trace-dialog--maintaining-properties pos
+    (delete-char 1)
+    (insert char)))
+
+
+;;;; Handlers for the *trace-dialog* and *trace-detail* buffers
+;;;
+(defun slime-trace-dialog--open-specs (traced-specs)
+  (cl-labels ((make-report-spec-fn
+               (&optional form)
+               #'(lambda (_button)
+                   (slime-eval-async
+                       `(cl:progn
+                         ,form
+                         (swank-trace-dialog:report-specs))
+                     #'(lambda (results)
+                         (slime-trace-dialog--open-specs results))))))
+    (slime-trace-dialog--refresh
+        (:overlay slime-trace-dialog--specs-overlay
+                  :recover-point-p t)
+      (insert
+       (slime-trace-dialog--format "Traced specs (%s)" (length traced-specs))
+       (slime-trace-dialog--button "[refresh]"
+                                   (make-report-spec-fn))
+       "\n" (make-string 50 ? )
+       (slime-trace-dialog--button
+        "[untrace all]"
+        (make-report-spec-fn `(swank-trace-dialog:dialog-untrace-all)))
+       "\n\n")
+      (cl-loop for spec in traced-specs
+               do (insert
+                   "  "
+                   (slime-trace-dialog--button
+                    "[untrace]"
+                    (make-report-spec-fn
+                     `(swank-trace-dialog:dialog-untrace ',spec)))
+                   (format " %s" spec)
+                   "\n")))))
+
+(defvar slime-trace-dialog--fetch-key nil)
+
+(defvar slime-trace-dialog--stop-fetching nil)
+
+(defun slime-trace-dialog--update-progress (total &optional show-stop-p remaining-p)
+  ;; `remaining-p' indicates `total' is the number of remaining traces.
+  (slime-trace-dialog--refresh
+      (:overlay slime-trace-dialog--progress-overlay
+                :recover-point-p t)
+    (let* ((done (hash-table-count slime-trace-dialog--traces))
+           (total (if remaining-p (+ done total) total)))
+      (insert
+       (slime-trace-dialog--format "Trace collection status (%d/%s)"
+                                   done
+                                   (or total "0"))
+       (slime-trace-dialog--button "[refresh]"
+                                   #'(lambda (_button)
+                                       (slime-trace-dialog-fetch-progress))))
+
+      (when (and total (cl-plusp (- total done)))
+        (insert "\n" (make-string 50 ? )
+                (slime-trace-dialog--button
+                 "[fetch next batch]"
+                 #'(lambda (_button)
+                     (slime-trace-dialog-fetch-traces nil)))
+                "\n" (make-string 50 ? )
+                (slime-trace-dialog--button
+                 "[fetch all]"
+                 #'(lambda (_button)
+                     (slime-trace-dialog-fetch-traces t)))))
+      (when total
+        (insert "\n" (make-string 50 ? )
+                (slime-trace-dialog--button
+                 "[clear]"
+                 #'(lambda (_button)
+                     (slime-trace-dialog-clear-fetched-traces)))))
+      (when show-stop-p
+        (insert "\n" (make-string 50 ? )
+                (slime-trace-dialog--button
+                 "[stop]"
+                 #'(lambda (_button)
+                     (setq slime-trace-dialog--stop-fetching t)))))
+      (insert "\n\n"))))
+
+(defun slime-trace-dialog--open-detail (trace-tuple &optional no-pop)
+  (slime-with-popup-buffer ("*trace-detail*" :select (not no-pop)
+                            :mode 'slime-trace-dialog--detail-mode)
+    (cl-destructuring-bind (id _parent-id _spec args retlist backtrace external)
+        trace-tuple
+      (let ((headline (slime-trace-dialog--format-trace-entry id external)))
+        (setq headline (format "%s\n%s\n"
+                               headline
+                               (make-string (length headline) ?-)))
+        (insert headline))
+      (cl-loop for (type objects label)
+               in `((:arg ,args   "Called with args:")
+                    (:retval ,retlist "Returned values:"))
+               do (insert (format "\n%s\n" label))
+               (insert (cl-loop for object in objects
+                                for i from 0
+                                concat (format "   %s: %s\n" i
+                                               (slime-trace-dialog--format-part
+                                                (cl-first object)
+                                                (cl-second object)
+                                                id
+                                                type)))))
+      (when backtrace
+        (insert "\nBacktrace:\n"
+                (cl-loop for (i spec) in backtrace
+                         concat (format "   %s: %s\n" i spec)))))))
+
+
+;;;; Rendering traces
+;;;
+(defun slime-trace-dialog--draw-tree-lines (start offset direction)
+  (save-excursion
+    (let ((inhibit-point-motion-hooks t))
+      (goto-char start)
+      (cl-loop with replace-set = (if (eq direction 'down)
+                                      '(? )
+                                    '(?  ?`))
+               for line-beginning = (line-beginning-position
+                                     (if (eq direction 'down)
+                                         2 0))
+               for pos = (+ line-beginning offset)
+               while (and (< (point-min) line-beginning)
+                          (< line-beginning (point-max))
+                          (memq (char-after pos) replace-set))
+               do
+               (slime-trace-dialog--go-replace-char-at pos "|")
+               (goto-char pos)))))
+
+(defun slime-trace-dialog--make-indent (depth suffix)
+  (concat (make-string (* 3 (max 0 (1- depth))) ? )
+          (if (cl-plusp depth) suffix)))
+
+(defun slime-trace-dialog--make-collapse-button (trace)
+  (slime-trace-dialog--button (if (slime-trace-dialog--trace-collapsed-p trace)
+                                  (cdr slime-trace-dialog--collapse-chars)
+                                (car slime-trace-dialog--collapse-chars))
+                              #'(lambda (button)
+                                  (slime-trace-dialog--set-collapsed
+                                   (not (slime-trace-dialog--trace-collapsed-p
+                                         trace))
+                                   trace
+                                   button))))
+
+
+(defun slime-trace-dialog--insert-trace (trace)
+  (let* ((id (slime-trace-dialog--trace-id trace))
+         (parent (slime-trace-dialog--trace-parent trace))
+         (has-children-p (slime-trace-dialog--trace-children-end trace))
+         (indent-spec (slime-trace-dialog--make-indent
+                       (slime-trace-dialog--trace-depth trace)
+                       "`--"))
+         (indent-summary (slime-trace-dialog--make-indent
+                          (slime-trace-dialog--trace-depth trace)
+                          "   "))
+         (autofollow-fn (slime-trace-dialog--make-autofollow-fn id))
+         (id-string (slime-trace-dialog--button
+                     (format "%4s" id)
+                     #'(lambda (_button)
+                         (slime-eval-async
+                             `(swank-trace-dialog:report-trace-detail
+                               ,id)
+                           #'slime-trace-dialog--open-detail))))
+         (spec (slime-trace-dialog--trace-spec trace))
+         (summary (cl-loop for (type objects marker) in
+                           `((:arg    ,(slime-trace-dialog--trace-args trace)
+                                      " > ")
+                             (:retval ,(slime-trace-dialog--trace-retlist trace)
+                                      " < "))
+                           concat (cl-loop for object in objects
+                                           concat "      "
+                                           concat indent-summary
+                                           concat marker
+                                           concat (slime-trace-dialog--format-part
+                                                   (cl-first object)
+                                                   (cl-second object)
+                                                   id
+                                                   type)
+                                           concat "\n"))))
+    (puthash id trace slime-trace-dialog--traces)
+    ;; insert and propertize the text
+    ;;
+    (setf (slime-trace-dialog--trace-beg trace) (point-marker))
+    (insert id-string " ")
+    (insert indent-spec)
+    (if has-children-p
+        (insert (slime-trace-dialog--make-collapse-button trace))
+      (setf (slime-trace-dialog--trace-collapse-button-marker trace)
+            (point-marker))
+      (insert "-"))
+    (insert (format " %s\n" spec))
+    (setf (slime-trace-dialog--trace-summary-beg trace) (point-marker))
+    (insert summary)
+    (setf (slime-trace-dialog--trace-end trace) (point-marker))
+    (set-marker-insertion-type (slime-trace-dialog--trace-beg trace) t)
+
+    (add-text-properties (slime-trace-dialog--trace-beg trace)
+                         (slime-trace-dialog--trace-end trace)
+                         (list 'slime-trace-dialog--id id
+                               'point-entered autofollow-fn
+                               'point-left autofollow-fn))
+    ;; respect brief mode and collapsed state
+    ;;
+    (cl-loop for condition in (list slime-trace-dialog-hide-details-mode
+                                    (slime-trace-dialog--trace-collapsed-p trace))
+             when condition
+             do (slime-trace-dialog--hide-unhide
+                 (slime-trace-dialog--trace-summary-beg
+                  trace)
+                 (slime-trace-dialog--trace-end trace)
+                 1))
+    (cl-loop for tr = trace then parent
+             for parent = (slime-trace-dialog--trace-parent tr)
+             while parent
+             when (slime-trace-dialog--trace-collapsed-p parent)
+             do (slime-trace-dialog--hide-unhide
+                 (slime-trace-dialog--trace-beg trace)
+                 (slime-trace-dialog--trace-end trace)
+                 (+ 1
+                    (or (get-text-property (slime-trace-dialog--trace-beg parent)
+                                           'slime-trace-dialog--hidden-level)
+                        0)))
+             (cl-return))
+    ;; maybe add the collapse-button to the parent in case it didn't
+    ;; have one already
+    ;;
+    (when (and parent
+               (slime-trace-dialog--trace-collapse-button-marker parent))
+      (slime-trace-dialog--maintaining-properties
+          (slime-trace-dialog--trace-collapse-button-marker parent)
+        (delete-char 1)
+        (insert (slime-trace-dialog--make-collapse-button parent))
+        (setf (slime-trace-dialog--trace-collapse-button-marker parent)
+              nil)))
+    ;; draw the tree lines
+    ;;
+    (when parent
+      (slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace)
+                                           (+ 2 (length indent-spec))
+                                           'up))
+    (when has-children-p
+      (slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace)
+                                           (+ 5 (length indent-spec))
+                                           'down))
+    ;; set the "children-end" slot
+    ;;
+    (unless (slime-trace-dialog--trace-children-end trace)
+      (cl-loop for parent = trace
+               then (slime-trace-dialog--trace-parent parent)
+               while parent
+               do
+               (setf (slime-trace-dialog--trace-children-end parent)
+                     (slime-trace-dialog--trace-end trace))))))
+
+(defun slime-trace-dialog--render-trace (trace)
+  ;; Render the trace entry in the appropriate place.
+  ;;
+  ;; A trace becomes a few lines of slightly propertized text in the
+  ;; buffer, inserted by `slime-trace-dialog--insert-trace', bound by
+  ;; point markers that we use here.
+  ;;
+  ;; The new trace might be replacing an existing one, or otherwise
+  ;; must be placed under its existing parent which might or might not
+  ;; be the last entry inserted.
+  ;;
+  (let ((existing (slime-trace-dialog--find-trace
+                   (slime-trace-dialog--trace-id trace)))
+        (parent (slime-trace-dialog--trace-parent trace)))
+    (cond (existing
+           ;; Other traces might already reference `existing' and with
+           ;; need to maintain that eqness. Best way to do that is
+           ;; destructively modify `existing' with the new retlist...
+           ;;
+           (setf (slime-trace-dialog--trace-retlist existing)
+                 (slime-trace-dialog--trace-retlist trace))
+           ;; Now, before deleting and re-inserting `existing' at an
+           ;; arbitrary point in the tree, note that it's
+           ;; "children-end" marker is already non-nil, and informs us
+           ;; about its parenthood status. We want to 1. leave it
+           ;; alone if it's already a parent, or 2. set it to nil if
+           ;; it's a leaf, thus forcing the needed update of the
+           ;; parents' "children-end" marker.
+           ;;
+           (when (= (slime-trace-dialog--trace-children-end existing)
+                    (slime-trace-dialog--trace-end existing))
+             (setf (slime-trace-dialog--trace-children-end existing) nil))
+           (delete-region (slime-trace-dialog--trace-beg existing)
+                          (slime-trace-dialog--trace-end existing))
+           (goto-char (slime-trace-dialog--trace-end existing))
+           ;; Remember to set `trace' to be `existing'
+           ;;
+           (setq trace existing))
+          (parent
+           (goto-char (1+ (slime-trace-dialog--trace-children-end parent))))
+          (;; top level trace
+           t
+           (goto-char (point-max))))
+    (goto-char (line-beginning-position))
+    (slime-trace-dialog--insert-trace trace)))
+
+(defun slime-trace-dialog--update-tree (tuples)
+  (save-excursion
+    (slime-trace-dialog--refresh
+        (:overlay slime-trace-dialog--tree-overlay
+                  :dont-erase t)
+      (cl-loop for tuple in tuples
+               for parent = (slime-trace-dialog--find-trace (cl-second tuple))
+               for trace = (slime-trace-dialog--make-trace
+                            :id (cl-first tuple)
+                            :parent parent
+                            :spec (cl-third tuple)
+                            :args (cl-fourth tuple)
+                            :retlist (cl-fifth tuple)
+                            :depth (if parent
+                                       (1+ (slime-trace-dialog--trace-depth
+                                            parent))
+                                     0))
+               do (slime-trace-dialog--render-trace trace)))))
+
+(defun slime-trace-dialog--clear-local-tree ()
+  (set (make-local-variable 'slime-trace-dialog--fetch-key)
+       (cl-gensym "slime-trace-dialog-fetch-key-"))
+  (set (make-local-variable 'slime-trace-dialog--traces)
+       (make-hash-table))
+  (slime-trace-dialog--refresh
+      (:overlay slime-trace-dialog--tree-overlay))
+  (slime-trace-dialog--update-progress nil))
+
+(defun slime-trace-dialog--on-new-results (results &optional recurse)
+  (cl-destructuring-bind (tuples remaining reply-key)
+      results
+    (cond ((and slime-trace-dialog--fetch-key
+                (string= (symbol-name slime-trace-dialog--fetch-key)
+                         (symbol-name reply-key)))
+           (slime-trace-dialog--update-tree tuples)
+           (slime-trace-dialog--update-progress
+            remaining
+            (and recurse
+                 (cl-plusp remaining))
+            t)
+           (when (and recurse
+                      (not (prog1 slime-trace-dialog--stop-fetching
+                             (setq slime-trace-dialog--stop-fetching nil)))
+                      (cl-plusp remaining))
+             (slime-eval-async `(swank-trace-dialog:report-partial-tree
+                                 ',reply-key)
+               #'(lambda (results) (slime-trace-dialog--on-new-results
+                                    results
+                                    recurse))))))))
+
+
+;;;; Interactive functions
+;;;
+(defun slime-trace-dialog-fetch-specs ()
+  "Refresh just list of traced specs."
+  (interactive)
+  (slime-eval-async `(swank-trace-dialog:report-specs)
+    #'slime-trace-dialog--open-specs))
+
+(defun slime-trace-dialog-fetch-progress ()
+  (interactive)
+  (slime-eval-async
+      '(swank-trace-dialog:report-total)
+    #'(lambda (total)
+        (slime-trace-dialog--update-progress
+         total))))
+
+(defun slime-trace-dialog-fetch-status ()
+  "Refresh just the status part of the SLIME Trace Dialog"
+  (interactive)
+  (slime-trace-dialog-fetch-specs)
+  (slime-trace-dialog-fetch-progress))
+
+(defun slime-trace-dialog-clear-fetched-traces (&optional interactive)
+  "Clear local and remote traces collected so far"
+  (interactive "p")
+  (when (or (not interactive)
+            (y-or-n-p "Clear all collected and fetched traces?"))
+    (slime-eval-async
+        '(swank-trace-dialog:clear-trace-tree)
+      #'(lambda (_ignored)
+          (slime-trace-dialog--clear-local-tree)))))
+
+(defun slime-trace-dialog-fetch-traces (&optional recurse)
+  (interactive "P")
+  (setq slime-trace-dialog--stop-fetching nil)
+  (slime-eval-async `(swank-trace-dialog:report-partial-tree
+                      ',slime-trace-dialog--fetch-key)
+    #'(lambda (results) (slime-trace-dialog--on-new-results results
+                                                            recurse))))
+
+(defun slime-trace-dialog-next-button (&optional goback)
+  (interactive)
+  (let ((finder (if goback
+                    #'previous-single-property-change
+                  #'next-single-property-change)))
+    (cl-loop for pos = (funcall finder (point) 'action)
+             while pos
+             do (goto-char pos)
+             until (get-text-property pos 'action))))
+
+(defun slime-trace-dialog-prev-button ()
+  (interactive)
+  (slime-trace-dialog-next-button 'goback))
+
+(defvar slime-trace-dialog-after-toggle-hook nil
+  "Hooks run after toggling a dialog-trace")
+
+(defun slime-trace-dialog-toggle-trace (&optional using-context-p)
+  "Toggle the dialog-trace of the spec at point.
+
+When USING-CONTEXT-P, attempt to decipher lambdas. methods and
+other complicated function specs."
+  (interactive "P")
+  ;; Notice the use of "spec strings" here as opposed to the
+  ;; proper cons specs we use on the swank side.
+  ;;
+  ;; Notice the conditional use of `slime-trace-query' found in
+  ;; swank-fancy-trace.el
+  ;;
+  (let* ((spec-string (if using-context-p
+                          (slime-extract-context)
+                        (slime-symbol-at-point)))
+         (spec-string (if (fboundp 'slime-trace-query)
+                          (slime-trace-query spec-string)
+                        spec-string)))
+    (message "%s" (slime-eval `(swank-trace-dialog:dialog-toggle-trace
+                                (swank::from-string ,spec-string))))
+    (run-hooks 'slime-trace-dialog-after-toggle-hook)))
+
+(defun slime-trace-dialog--update-existing-dialog ()
+  (let ((existing (slime-trace-dialog--live-dialog)))
+    (when existing
+      (with-current-buffer existing
+        (slime-trace-dialog-fetch-status)))))
+
+(add-hook 'slime-trace-dialog-after-toggle-hook
+          'slime-trace-dialog--update-existing-dialog)
+
+(defun slime-trace-dialog-toggle-complex-trace ()
+  "Toggle the dialog-trace of the complex spec at point.
+
+See `slime-trace-dialog-toggle-trace'."
+  (interactive)
+  (slime-trace-dialog-toggle-trace t))
+
+(defun slime-trace-dialog (&optional clear-and-fetch)
+  "Show trace dialog and refresh trace collection status.
+
+With optional CLEAR-AND-FETCH prefix arg, clear the current tree
+and fetch a first batch of traces."
+  (interactive "P")
+  (with-current-buffer
+      (pop-to-buffer (slime-trace-dialog--ensure-buffer))
+    (slime-trace-dialog-fetch-status)
+    (when (or clear-and-fetch
+              (null slime-trace-dialog--fetch-key))
+      (slime-trace-dialog--clear-local-tree))
+    (when clear-and-fetch
+      (slime-trace-dialog-fetch-traces nil))))
+
+(defun slime-trace-dialog-copy-down-to-repl (id part-id type)
+  "Eval the Trace Dialog entry under point in the REPL (to set *)"
+  (interactive (cl-loop for prop in '(slime-trace-dialog--id
+                                      slime-trace-dialog--part-id
+                                      slime-trace-dialog--type)
+                        collect (get-text-property (point) prop)))
+  (unless (and id part-id type) (error "No trace part at point %s" (point)))
+  (slime-repl-send-string
+   (format "%s" `(nth-value 0
+                            (swank-trace-dialog::find-trace-part
+                             ,id ,part-id ,type))))
+  (slime-repl))
+
+(provide 'slime-trace-dialog)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-tramp.el

@@ -0,0 +1,121 @@
+(require 'slime)
+(require 'tramp)
+(eval-when-compile (require 'cl)) ; lexical-let
+
+(define-slime-contrib slime-tramp
+  "Filename translations for tramp"
+  (:authors "Marco Baringer <mb@bese.it>")
+  (:license "GPL")
+  (:on-load 
+   (setq slime-to-lisp-filename-function #'slime-tramp-to-lisp-filename)
+   (setq slime-from-lisp-filename-function #'slime-tramp-from-lisp-filename)))
+
+(defcustom slime-filename-translations nil
+  "Assoc list of hostnames and filename translation functions.  
+Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP).
+
+HOSTNAME-REGEXP is a regexp which is applied to the connection's
+slime-machine-instance. If HOSTNAME-REGEXP maches then the
+corresponding TO-LISP and FROM-LISP functions will be used to
+translate emacs filenames and lisp filenames.
+
+TO-LISP will be passed the filename of an emacs buffer and must
+return a string which the underlying lisp understandas as a
+pathname. FROM-LISP will be passed a pathname as returned by the
+underlying lisp and must return something that emacs will
+understand as a filename (this string will be passed to
+find-file).
+
+This list will be traversed in order, so multiple matching
+regexps are possible.
+
+Example:
+
+Assuming you run emacs locally and connect to slime running on
+the machine 'soren' and you can connect with the username
+'animaliter':
+
+  (push (list \"^soren$\"
+              (lambda (emacs-filename)
+                (subseq emacs-filename (length \"/ssh:animaliter@soren:\")))
+              (lambda (lisp-filename)
+                (concat \"/ssh:animaliter@soren:\" lisp-filename)))
+        slime-filename-translations)
+
+See also `slime-create-filename-translator'."
+  :type '(repeat (list :tag "Host description"
+                       (regexp :tag "Hostname regexp")
+                       (function :tag "To   lisp function")
+                       (function :tag "From lisp function")))
+  :group 'slime-lisp)
+
+(defun slime-find-filename-translators (hostname)
+  (cond ((cdr (cl-assoc-if (lambda (regexp) (string-match regexp hostname))
+                           slime-filename-translations)))
+        (t (list #'identity #'identity))))
+
+(defun slime-make-tramp-file-name (username remote-host lisp-filename)
+  "Tramp compatability function.
+
+Handles the signature of `tramp-make-tramp-file-name' changing
+over time."
+  (cond
+   ((>= emacs-major-version 26)
+    ;; Emacs 26 requires the method to be provided and the signature of
+    ;; `tramp-make-tramp-file-name' has changed.
+    (tramp-make-tramp-file-name (tramp-find-method nil username remote-host)
+                                username
+                                nil
+                                remote-host
+                                nil
+                                lisp-filename))
+   ((boundp 'tramp-multi-methods)
+    (tramp-make-tramp-file-name nil nil
+                                username
+                                remote-host
+                                lisp-filename))
+   (t
+    (tramp-make-tramp-file-name nil
+                                username
+                                remote-host
+                                lisp-filename))))
+
+(cl-defun slime-create-filename-translator (&key machine-instance
+                                                 remote-host
+                                                 username)
+  "Creates a three element list suitable for push'ing onto
+slime-filename-translations which uses Tramp to load files on
+hostname using username. MACHINE-INSTANCE is a required
+parameter, REMOTE-HOST defaults to MACHINE-INSTANCE and USERNAME
+defaults to (user-login-name).
+
+MACHINE-INSTANCE is the value returned by slime-machine-instance,
+which is just the value returned by cl:machine-instance on the
+remote lisp. REMOTE-HOST is the fully qualified domain name (or
+just the IP) of the remote machine. USERNAME is the username we
+should login with.
+The functions created here expect your tramp-default-method or
+ tramp-default-method-alist to be setup correctly."
+  (lexical-let ((remote-host (or remote-host machine-instance))
+                (username (or username (user-login-name))))
+    (list (concat "^" machine-instance "$")
+          (lambda (emacs-filename)
+            (tramp-file-name-localname
+             (tramp-dissect-file-name emacs-filename)))
+          `(lambda (lisp-filename)
+             (slime-make-tramp-file-name
+              ,username
+              ,remote-host
+              lisp-filename)))))
+
+(defun slime-tramp-to-lisp-filename (filename)
+  (funcall (if (slime-connected-p)
+               (first (slime-find-filename-translators (slime-machine-instance)))
+               'identity)
+           (expand-file-name filename)))
+
+(defun slime-tramp-from-lisp-filename (filename)
+  (funcall (second (slime-find-filename-translators (slime-machine-instance)))
+           filename))
+
+(provide 'slime-tramp)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-typeout-frame.el

@@ -0,0 +1,92 @@
+(require 'slime)
+(require 'slime-autodoc)
+(require 'cl-lib)
+
+(defvar slime-typeout-frame-unbind-stack ())
+
+(define-slime-contrib slime-typeout-frame
+  "Display messages in a dedicated frame."
+  (:authors "Luke Gorrie  <luke@synap.se>")
+  (:license "GPL")
+  (:on-load
+   (unless (slime-typeout-tty-only-p)
+     (add-hook 'slime-connected-hook 'slime-ensure-typeout-frame)
+     (add-hook 'slime-autodoc-mode-hook 'slime-typeout-wrap-autodoc)
+     (cl-loop for (var value) in 
+              '((slime-message-function slime-typeout-message)
+                (slime-background-message-function slime-typeout-message))
+              do (slime-typeout-frame-init-var var value))))
+  (:on-unload
+   (remove-hook 'slime-connected-hook 'slime-ensure-typeout-frame)
+   (remove-hook 'slime-autodoc-mode-hook 'slime-typeout-wrap-autodoc)
+   (cl-loop for (var value) in slime-typeout-frame-unbind-stack 
+            do (cond ((eq var 'slime-unbound) (makunbound var))
+                     (t (set var value))))
+   (setq slime-typeout-frame-unbind-stack nil)))
+
+(defun slime-typeout-frame-init-var (var value)
+  (push (list var (if (boundp var) (symbol-value var) 'slime-unbound))
+	slime-typeout-frame-unbind-stack)
+  (set var value))
+
+(defun slime-typeout-tty-only-p ()
+  (cond ((featurep 'xemacs)
+	 (null (remove 'tty (mapcar #'device-type (console-device-list)))))
+	(t (not (window-system)))))
+
+
+;;;; Typeout frame
+
+;; When a "typeout frame" exists it is used to display certain
+;; messages instead of the echo area or pop-up windows.
+
+(defvar slime-typeout-window nil
+  "The current typeout window.")
+
+(defvar slime-typeout-frame-properties
+  '((height . 10) (minibuffer . nil))
+  "The typeout frame properties (passed to `make-frame').")
+
+(defun slime-typeout-buffer ()
+  (with-current-buffer (get-buffer-create (slime-buffer-name :typeout))
+    (setq buffer-read-only t)
+    (current-buffer)))
+
+(defun slime-typeout-active-p ()
+  (and slime-typeout-window
+       (window-live-p slime-typeout-window)))
+
+(defun slime-typeout-message-aux (format-string &rest format-args)
+  (slime-ensure-typeout-frame)
+  (with-current-buffer (slime-typeout-buffer)
+    (let ((inhibit-read-only t)
+          (msg (apply #'format format-string format-args)))
+      (unless (string= msg "")
+	(erase-buffer)
+	(insert msg)))))
+
+(defun slime-typeout-message (format-string &rest format-args)
+  (apply #'slime-typeout-message-aux format-string format-args))
+
+(defun slime-make-typeout-frame ()
+  "Create a frame for displaying messages (e.g. arglists)."
+  (interactive)
+  (let ((frame (make-frame slime-typeout-frame-properties)))
+    (save-selected-window
+      (select-window (frame-selected-window frame))
+      (switch-to-buffer (slime-typeout-buffer))
+      (setq slime-typeout-window (selected-window)))))
+
+(defun slime-ensure-typeout-frame ()
+  "Create the typeout frame unless it already exists."
+  (interactive)
+  (if (slime-typeout-active-p)
+      (save-selected-window
+        (select-window slime-typeout-window)
+        (switch-to-buffer (slime-typeout-buffer)))
+    (slime-make-typeout-frame)))
+
+(defun slime-typeout-wrap-autodoc ()
+  (setq eldoc-message-function 'slime-typeout-message-aux))
+
+(provide 'slime-typeout-frame)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-xref-browser.el

@@ -0,0 +1,99 @@
+(eval-and-compile
+  (require 'slime))
+
+(define-slime-contrib slime-xref-browser
+  "Xref browsing with tree-widget"
+  (:authors "Rui Patrocínio <rui.patrocinio@netvisao.pt>")
+  (:license "GPL"))
+
+
+;;;; classes browser
+
+(defun slime-expand-class-node (widget)
+  (or (widget-get widget :args)
+      (let ((name (widget-get widget :tag)))
+	(cl-loop for kid in (slime-eval `(swank:mop :subclasses ,name))
+                 collect `(tree-widget :tag ,kid
+                                       :expander slime-expand-class-node
+                                       :has-children t)))))
+
+(defun slime-browse-classes (name)
+  "Read the name of a class and show its subclasses."
+  (interactive (list (slime-read-symbol-name "Class Name: ")))
+  (slime-call-with-browser-setup 
+   (slime-buffer-name :browser) (slime-current-package) "Class Browser"
+   (lambda ()
+     (widget-create 'tree-widget :tag name 
+                    :expander 'slime-expand-class-node 
+                    :has-echildren t))))
+
+(defvar slime-browser-map nil
+  "Keymap for tree widget browsers")
+
+(require 'tree-widget)
+(unless slime-browser-map
+  (setq slime-browser-map (make-sparse-keymap))
+  (set-keymap-parent slime-browser-map widget-keymap)
+  (define-key slime-browser-map "q" 'bury-buffer))
+
+(defun slime-call-with-browser-setup (buffer package title fn)
+  (switch-to-buffer buffer)
+  (kill-all-local-variables)
+  (setq slime-buffer-package package)
+  (let ((inhibit-read-only t)) (erase-buffer))
+  (widget-insert title "\n\n")
+  (save-excursion
+    (funcall fn))
+  (lisp-mode-variables t)
+  (slime-mode t)
+  (use-local-map slime-browser-map)
+  (widget-setup))
+
+
+;;;; Xref browser
+
+(defun slime-fetch-browsable-xrefs (type name)
+  "Return a list ((LABEL DSPEC)).
+LABEL is just a string for display purposes. 
+DSPEC can be used to expand the node."
+  (let ((xrefs '()))
+    (cl-loop for (_file . specs) in (slime-eval `(swank:xref ,type ,name)) do
+             (cl-loop for (dspec . _location) in specs do
+                      (let ((exp (ignore-errors (read (downcase dspec)))))
+                        (cond ((and (consp exp) (eq 'flet (car exp)))
+                               ;; we can't expand FLET references so they're useless
+                               )
+                              ((and (consp exp) (eq 'method (car exp)))
+                               ;; this isn't quite right, but good enough for now
+                               (push (list dspec (string (cl-second exp))) xrefs))
+                              (t
+                               (push (list dspec dspec) xrefs))))))
+    xrefs))
+
+(defun slime-expand-xrefs (widget)
+  (or (widget-get widget :args)
+      (let* ((type (widget-get widget :xref-type))
+             (dspec (widget-get widget :xref-dspec))
+             (xrefs (slime-fetch-browsable-xrefs type dspec)))
+        (cl-loop for (label dspec) in xrefs
+                 collect `(tree-widget :tag ,label
+                                       :xref-type ,type
+                                       :xref-dspec ,dspec
+                                       :expander slime-expand-xrefs
+                                       :has-children t)))))
+
+(defun slime-browse-xrefs (name type)
+  "Show the xref graph of a function in a tree widget."
+  (interactive 
+   (list (slime-read-from-minibuffer "Name: "
+                                     (slime-symbol-at-point))
+         (read (completing-read "Type: " (slime-bogus-completion-alist
+                                          '(":callers" ":callees" ":calls"))
+                                nil t ":"))))
+  (slime-call-with-browser-setup 
+   (slime-buffer-name :xref) (slime-current-package) "Xref Browser"
+   (lambda ()
+     (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name 
+                    :expander 'slime-expand-xrefs :has-echildren t))))
+
+(provide 'slime-xref-browser)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-asdf.lisp

@@ -0,0 +1,541 @@
+;;; 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)))
+
+;; Doing list-all-systems-in-central-registry might be quite slow
+;; since it accesses a file-system, so run it once at the background
+;; to initialize caches.
+(when (eql *communication-style* :spawn)
+  (spawn (lambda ()
+           (ignore-errors (list-all-systems-in-central-registry)))
+         :name "init-asdf-fs-caches"))
+
+;;; Hook for compile-file-for-emacs
+
+(defun try-compile-file-with-asdf (pathname load-p &rest options)
+  (declare (ignore options))
+  (let ((component (pathname-component pathname)))
+    (when component
+      ;;(format t "~&Compiling ASDF component ~S~%" component)
+      (let ((op (make-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)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-goo.goo

@@ -0,0 +1,995 @@
+;;;; swank-goo.goo --- Swank server for GOO
+;;;
+;;; Copyright (C) 2005  Helmut Eller
+;;;
+;;; This file is licensed under the terms of the GNU General Public
+;;; License as distributed with Emacs (press C-h C-c to view it).
+
+;;;; Installation
+;;
+;; 1. Add something like this to your .emacs:
+;;
+;; (setq slime-lisp-implementations
+;;       '((goo ("g2c") :init goo-slime-init)))
+;; 
+;; (defun goo-slime-init (file _)
+;;   (format "%S\n%S\n"
+;; 	  `(set goo/system:*module-search-path*
+;; 		(cat '(".../slime/contrib/")
+;; 		     goo/system:*module-search-path*))
+;; 	  `(swank-goo:start-swank ,file)))
+;;
+;; 2. Start everything with  M-- M-x slime goo
+;;
+
+;;;; Code
+
+(use goo)
+(use goo/boot)
+(use goo/x)
+(use goo/io/port)
+(use goo/io/write)
+(use goo/eval)
+(use goo/system)
+(use goo/conditions)
+(use goo/fun)
+(use goo/loc)
+(use goo/chr)
+(use eval/module)
+(use eval/ast)
+(use eval/g2c)
+
+
+;;;; server setup
+
+(df create-server (port-number) (setup-server port-number announce-port))
+
+(df start-swank (port-file)
+  (setup-server 0 (fun (s) (write-port-file (%local-port s) port-file))))
+
+(df setup-server (port-number announce)
+  (let ((s (create-socket port-number)))
+    (fin (seq
+           (announce s)
+           (let ((c (accept s)))
+             ;;(post "connection: %s"  c)
+             (fin (serve-requests c)
+               (%close (@fd c)))))
+      (post "closing socket: %s" s)
+      (%close s))))
+
+(df announce-port (socket)
+  (post "Listening on port: %d\n" (%local-port socket)))
+
+(df write-port-file (port-number filename)
+  (with-port (file (open <file-out-port> filename))
+    (msg file "%d\n" port-number)))
+
+(dc <slime-toplevel> (<restart>))
+
+(dc <connection> (<any>))
+(dp @socket (<connection> => <port>))
+(dp @in (<connection> => <in-port>))
+(dp @out (<connection> => <out-port>))
+
+(dv emacs-connection|(t? <connection>) #f)
+
+(df serve-requests (socket)
+  (dlet ((emacs-connection (new <connection> 
+                             @socket socket
+                             @out (new <slime-out-port> @socket socket)
+                             @in (new <slime-in-port> @socket socket))))
+    (dlet ((out (@out emacs-connection))
+           (in (@in emacs-connection)))
+      (while #t
+        (simple-restart 
+         <slime-toplevel> "SLIME top-level"
+         (fun () (process-next-event socket)))))))
+
+(d. <nil> (t= 'nil))
+(d. t #t)
+(d. cons pair)
+
+(dv tag-counter|<int> 0)
+
+(df process-next-event (port) (dispatch-event (decode-message port) port))
+  
+(df dispatch-event (event port)
+  ;; (post "%=\n" event)
+  (match event
+    ((:emacs-rex ,form ,package ,_thread-id ,id)
+     (eval-for-emacs form package port id))
+    ((:read-string ,_)
+     (def tag (incf tag-counter))
+     (encode-message `(:read-string ,_ ,tag) port)
+     (rep loop ()
+       (match (decode-message port)
+         ((:emacs-return-string ,_ ,rtag ,str)
+          (assert (= tag rtag) "Unexpected reply tag: %d" rtag)
+          str)
+         ((,@evt)
+          (try-recover
+           (fun () (dispatch-event evt port))
+           (fun () (encode-message `(:read-aborted ,_ ,tag) port)))
+          (loop)))))
+    ((:emacs-return-string ,_ ,rtag ,str)
+     (error "Unexpected event: %=" event))
+    ((,@_) (encode-message event port))))
+
+(dc <eval-context> (<any>))
+(dp @module (<eval-context> => <module>))
+(dp @id (<eval-context> => <int>))
+(dp @port (<eval-context> => <port>))
+(dp @prev (<eval-context> => (t? <eval-context>)))
+
+;; should be ddv
+(dv eval-context|(t? <eval-context>) #f)
+
+(df buffer-module () (@module eval-context))
+
+(df eval-for-emacs (form|<lst> package|(t+ <str> <nil>) port id|<int>)
+  (try-recover
+   (fun () 
+     (try <condition> debugger-hook 
+       (dlet ((eval-context (new <eval-context> 
+                              @module (find-buffer-module package) @id id
+                              @port port @prev eval-context)))
+         (def result (eval (frob-form-for-eval form) 'swank-goo))
+         (force-out out)
+         (dispatch-event `(:return (:ok ,result) ,id) port))))
+   (fun () (dispatch-event `(:return (:abort) ,id) port))))
+
+(dm find-buffer-module (name|<str> => <module>)
+  (or (elt-or (all-modules) (as-sym name) #f)
+      (find-buffer-module 'nil)))
+
+(dm find-buffer-module (name|<nil> => <module>) default-module)
+
+(dv default-module|<module> (runtime-module 'goo/user))
+
+(d. slimefuns (fab <tab> 100))
+
+(ds defslimefun (,name ,args ,@body)
+  `(set (elt slimefuns ',name) 
+        (df ,(cat-sym 'swank@ name) ,args ,@body)))
+
+(df slimefun (name) 
+  (or (elt-or slimefuns name #f)
+      (error "Undefined slimefun: %=" name)))
+
+;; rewrite (swank:foo ...) to ((slimefun 'foo) ...)
+(df frob-form-for-eval (form)
+  (match form
+    ((,op ,@args)
+     (match (map as-sym (split (sym-name op) #\:))
+       ((swank ,name)
+        `((slimefun ',name) ,@args))))))
+
+
+;;;; debugger 
+
+(dc <sldb-context> (<any>))
+(dp @level (<sldb-context> => <int>))
+(dp @top-frame (<sldb-context> => <lst>))
+(dp @restarts (<sldb-context> => <lst>))
+(dp @condition (<sldb-context> => <condition>))
+(dp @eval-context (<sldb-context> => (t? <eval-context>)))
+
+(dv sldb-context|(t? <sldb-context>) #f)
+
+(df debugger-hook (c|<condition> resume)
+  (let ((tf (find-top-frame 'debugger-hook 2))
+        (rs (compute-restarts c))
+        (l (if sldb-context (1+ (@level sldb-context)) 1)))
+    (cond ((> l 10) (emergency-abort c))
+          (#t
+           (dlet ((sldb-context (new <sldb-context> 
+                                  @level l @top-frame tf 
+                                  @restarts rs @condition c
+                                  @eval-context eval-context)))
+             (let ((bt (compute-backtrace tf 0 10)))
+               (force-out out)
+               (dispatch-event `(:debug 0 ,l 
+                                        ,@(debugger-info c rs bt eval-context))
+                               (@port eval-context))
+               (sldb-loop l (@port eval-context))))))))
+
+(df emergency-abort (c)
+  (post "Maximum debug level reached aborting...\n")
+  (post "%s\n" (describe-condition c))
+  (do-stack-frames (fun (f args) (msg out " %= %=\n" f args)))
+  (invoke-handler-interactively (find-restart <slime-toplevel>) in out))
+
+(df sldb-loop (level port)
+  (fin (while #t
+         (dispatch-event `(:debug-activate 0 ,level) port)
+         (simple-restart
+          <restart> (msg-to-str "Return to SLDB level %s" level)
+          (fun () (process-next-event port))))
+    (dispatch-event `(:debug-return 0 ,level nil) port)))
+
+(defslimefun backtrace (start|<int> end|(t+ <int> <nil>)) 
+  (backtrace-for-emacs 
+   (compute-backtrace (@top-frame sldb-context) 
+                      start 
+                      (if (isa? end <int>) end #f))))
+
+(defslimefun throw-to-toplevel ()
+  (invoke-handler-interactively (find-restart <slime-toplevel>) in out))
+
+(defslimefun invoke-nth-restart-for-emacs (sldb-level|<int> n|<int>)
+  (when (= (@level sldb-context) sldb-level)
+    (invoke-handler-interactively (elt (@restarts sldb-context) n) in out)))
+
+(defslimefun debugger-info-for-emacs (start end)
+  (debugger-info (@condition sldb-context) 
+                 (@restarts sldb-context)
+                 (compute-backtrace (@top-frame sldb-context)
+                                    start
+                                    (if (isa? end <int>) end #f))))
+
+(defslimefun frame-locals-and-catch-tags (frame-idx)
+  (def frame (nth-frame frame-idx))
+  (list
+   (map-keyed (fun (i name) 
+                (lst ':name (sym-name name) ':id 0 
+                     ':value (safe-write-to-string (frame-var-value frame i))))
+              (frame-var-names frame))
+   '()))
+
+(defslimefun inspect-frame-var (frame-idx var-idx)
+  (reset-inspector)
+  (inspect-object (frame-var-value (nth-frame frame-idx) var-idx)))
+
+(defslimefun inspect-current-condition ()
+  (reset-inspector)
+  (inspect-object (@condition sldb-context)))
+
+(defslimefun frame-source-location (frame-idx)
+  (match (nth-frame frame-idx)
+    ((,f ,@_)
+     (or (emacs-src-loc f)
+         `(:error ,(msg-to-str "No src-loc available for: %s" f))))))
+
+(defslimefun eval-string-in-frame (string frame-idx)
+  (def frame (nth-frame frame-idx))
+  (let ((names (frame-var-names frame))
+        (values (frame-var-values frame)))
+    (write-to-string 
+     (app (eval `(fun ,names ,(read-from-string string)) 
+                (module-name (buffer-module)))
+          values))))
+
+(df debugger-info (condition restarts backtrace eval-context)
+  (lst `(,(try-or (fun () (describe-condition condition)) "<...>")
+         ,(cat "  [class: " (class-name-str condition) "]")
+         ())
+       (restarts-for-emacs restarts)
+       (backtrace-for-emacs backtrace)
+       (pending-continuations eval-context)))
+
+(df backtrace-for-emacs (backtrace)
+  (map (fun (f) 
+         (match f
+           ((,idx (,f ,@args))
+            (lst idx (cat (if (fun-name f) 
+                              (sym-name (fun-name f))
+                              (safe-write-to-string f))
+                          (safe-write-to-string args))))))
+       backtrace))
+
+(df restarts-for-emacs (restarts)
+  (map (fun (x) `(,(sym-name (class-name (%handler-condition-type x)))
+                  ,(describe-restart x)))
+       restarts))
+
+(df describe-restart (restart)
+  (describe-handler (%handler-info restart) (%handler-condition-type restart)))
+
+(df compute-restarts (condition) 
+  (packing (%do-handlers-of-type <restart> (fun (c) (pack c)))))
+
+(df find-restart (type)
+  (esc ret 
+    (%do-handlers-of-type type ret)
+    #f))
+
+(df pending-continuations (context|(t? <eval-context>))
+  (if context
+      (pair (@id context) (pending-continuations (@prev context)))
+      '()))
+
+(df find-top-frame (fname|<sym> offset|<int>)
+  (esc ret 
+    (let ((top-seen? #f))
+      (do-stack-frames (fun (f args) 
+                         (cond (top-seen?
+                                (cond ((== offset 0) 
+                                       (ret (pair f args)))
+                                      (#t (decf offset))))
+                               ((== (fun-name f) fname)
+                                (set top-seen? #t))))))))
+
+(df compute-backtrace (top-frame start|<int> end)
+  (packing
+      (esc break
+        (do-user-frames (fun (idx f args)
+                          (when (and end (<= end idx))
+                            (break #f))
+                          (when (<= start idx)
+                            (pack (lst idx (pair f args)))))
+                        top-frame))))
+
+(df nth-frame (n|<int>)
+  (esc ret 
+    (do-user-frames 
+     (fun (idx f args) 
+       (when (= idx n) 
+         (ret (pair f args))))
+     (@top-frame sldb-context))))
+
+(df frame-var-value (frame var-idx)
+  (match frame
+    ((,f ,@args)
+     (def sig (fun-sig f))
+     (def arity (sig-arity sig))
+     (def nary? (sig-nary? sig))
+     (cond ((< var-idx arity) (elt args var-idx))
+           (nary? (sub* args arity))))))
+
+(df frame-var-names (frame)
+  (match frame
+    ((,f ,@_) (fun-info-names (fun-info f)))))
+
+(df frame-var-values (frame)
+  (map (curry frame-var-value frame) (keys (frame-var-names frame))))
+
+(df do-user-frames (f|<fun> top-frame)
+  (let ((idx -1)
+        (top-seen? #f))
+    (do-stack-frames
+     (fun (ffun args)
+       (cond (top-seen?
+              (incf idx)
+              (f idx ffun (rev args)))
+             ((= (pair ffun args) top-frame) 
+              (set top-seen? #t)))))))
+
+
+;;;; Write some classes a little less verbose
+
+;; (dm recurring-write (port|<out-port> x d|<int> recur|<fun>)
+;;   (msg port "#{%s &%s}" (class-name-str x) 
+;;        (num-to-str-base (address-of x) 16)))
+
+(dm recurring-write (port|<out-port> x|<module> d|<int> recur|<fun>)
+  (msg port "#{%s %s}" (class-name-str x) (module-name x)))
+
+(dm recurring-write (port|<out-port> x|<module-binding> d|<int> recur|<fun>)
+  (msg port "#{%s %s}" (class-name-str x) (binding-name x)))
+
+(dm recurring-write (port|<out-port> x|<tab> d|<int> recur|<fun>)
+  (msg port "#{%s %s}" (class-name-str x) (len x)))
+
+(dm recurring-write (port|<out-port> x|<static-global-environment> 
+                                     d|<int> recur|<fun>)
+  (msg port "#{%s}" (class-name-str x)))
+
+(dm recurring-write (port|<out-port> x|<regular-application>
+                                     d|<int> recur|<fun>)
+  (msg port "#{%s}" (class-name-str x)))
+
+(dm recurring-write (port|<out-port> x|<src-loc> d|<int> recur|<fun>)
+  (msg port "#{%s %s:%=}" (class-name-str x)
+       (src-loc-file x) (src-loc-line x)))
+
+
+;;;; Inspector
+
+(dc <inspector> (<any>))
+(dp! @object (<inspector> => <any>))
+(dp! @parts (<inspector> => <vec>) (new <vec>))
+(dp! @stack (<inspector> => <lst>) '())
+
+(dv inspector #f)
+
+(defslimefun init-inspector (form|<str>)
+  (reset-inspector)
+  (inspect-object (str-eval form (buffer-module))))
+
+(defslimefun quit-inspector () (reset-inspector) 'nil)
+
+(defslimefun inspect-nth-part (n|<int>)
+  (inspect-object (elt (@parts inspector) n)))
+
+(defslimefun inspector-pop ()
+  (cond ((<= 2 (len (@stack inspector)))
+         (popf (@stack inspector))
+         (inspect-object (popf (@stack inspector))))
+        (#t 'nil)))
+
+(df reset-inspector () (set inspector (new <inspector>)))
+
+(df inspect-object (o)
+  (set (@object inspector) o)
+  (set (@parts inspector) (new <vec>))
+  (pushf (@stack inspector) o)
+  (lst ':title (safe-write-to-string o) ; ':type (class-name-str o)
+       ':content (inspector-content 
+                  `("class: " (:value ,(class-of o)) "\n" 
+                    ,@(inspect o)))))
+
+(df inspector-content (content) 
+  (map (fun (part)
+         (case-by part isa?
+           ((<str>) part)
+           ((<lst>)
+            (match part
+              ((:value ,o ,@str)
+               `(:value ,@(if (nul? str) 
+                              (lst (safe-write-to-string o))
+                              str)
+                        ,(assign-index o)))))
+           (#t (error "Bad inspector content: %=" part))))
+       content))
+
+(df assign-index (o)
+  (pushf (@parts inspector) o)
+  (1- (len (@parts inspector))))
+
+(dg inspect (o))
+
+;; a list of dangerous functions 
+(d. getter-blacklist (lst fun-code fun-env class-row))
+
+(dm inspect (o)
+  (join (map (fun (p) 
+               (let ((getter (prop-getter p)))
+                 `(,(sym-name (fun-name getter)) ": "
+                   ,(cond ((mem? getter-blacklist getter) "<...>")
+                          ((not (prop-bound? o getter)) "<unbound>")
+                          (#t (try-or (fun () `(:value ,(getter o)))
+                                      "<...>"))))))
+             (class-props (class-of o)))
+        '("\n")))
+
+(dm inspect (o|<seq>)
+  (join (packing (do-keyed (fun (pos val) 
+                             (pack `(,(num-to-str pos) ": " (:value ,val))))
+                           o))
+        '("\n")))
+
+(dm inspect (o|<tab>)
+  (join (packing (do-keyed (fun (key val) 
+                             (pack `((:value ,key) "\t: " (:value ,val))))
+                           o))
+        '("\n")))
+
+;; inspecting the env of closures is broken
+;; (dm inspect (o|<met>)
+;;   (cat (sup o)
+;;        '("\n")
+;;        (if (%fun-env? o)
+;;            (inspect (packing (for ((i (below (%fun-env-len o))))
+;;                                (pack (%fun-env-elt o i)))))
+;;            '())))
+;; 
+;; (df %fun-env?    (f|<met> => <log>)         #eb{ FUNENV($f) != $#f })
+;; (df %fun-env-len (f|<met> => <int>)         #ei{ ((ENV)FUNENV ($f))->size })
+;; (df %fun-env-elt (f|<met> i|<int> => <any>) #eg{ FUNENVGET($f, @i) })
+
+
+;;;; init 
+
+(defslimefun connection-info ()
+  `(:pid 
+    ,(process-id) :style nil
+    :lisp-implementation (:type "GOO" :name "goo" 
+                                :version ,(%lookup '*goo-version* 'eval/main))
+    :machine (:instance "" :type "" :version "")
+    :features () 
+    :package (:name "goo/user" :prompt "goo/user")))
+
+(defslimefun quit-lisp () #ei{ exit (0),0 })
+
+(defslimefun set-default-directory (dir|<str>) #ei{ chdir(@dir) } dir)
+
+
+;;;; eval
+
+(defslimefun ping () "PONG")
+
+(defslimefun create-repl (_)
+  (let ((name (sym-name (module-name (buffer-module)))))
+    `(,name ,name)))
+
+(defslimefun listener-eval (string)
+  (clear-input in)
+  `(:values ,(write-to-string (str-eval string (buffer-module)))))
+
+(defslimefun interactive-eval (string)
+  (cat "=> " (write-to-string (str-eval string (buffer-module)))))
+
+(df str-eval (s|<str> m|<module>) 
+  (eval (read-from-string s) (module-name m)))
+
+(df clear-input (in|<in-port>) (while (ready? in) (get in)))
+
+(dc <break> (<restart>))
+
+(defslimefun simple-break ()
+  (simple-restart 
+   <break> "Continue from break"
+   (fun () (sig (new <simple-condition> 
+                  condition-message "Interrupt from Emacs"))))
+  'nil)
+
+(defslimefun clear-repl-results () 'nil)
+
+
+;;;; compile
+
+(defslimefun compile-string-for-emacs (string buffer position directory)
+  (def start (current-time))
+  (def r (g2c-eval (read-from-string string) 
+                   (module-target-environment (buffer-module))))
+  (lst (write-to-string r)
+       (/ (as <flo> (- (current-time) start)) 1000000.0)))
+
+(defslimefun compiler-notes-for-emacs () 'nil)
+
+(defslimefun filename-to-modulename (filename|<str> => (t+ <str> <nil>))
+  (try-or (fun () (sym-name (filename-to-modulename filename))) 'nil))
+
+(df filename-to-modulename (filename|<str> => <sym>)
+  (def paths (map pathname-to-components
+                  (map simplify-filename
+                       (pick file-exists? *module-search-path*))))
+  (def filename (pathname-to-components filename))
+  (def moddir (rep parent ((modpath filename))
+                (cond ((any? (curry = modpath) paths) 
+                       modpath)
+                      (#t 
+                       (parent (components-parent-directory modpath))))))
+  (def modfile (components-to-pathname (sub* filename (len moddir))))
+  (as-sym (sub modfile 0 (- (len modfile) (len *goo-extension*)))))
+
+
+
+;;;; Load
+
+(defslimefun load-file (filename)
+  (let ((file (cond ((= (sub (rev filename) 0 4) "oog.") filename)
+                    (#t (cat filename ".goo")))))
+    (safe-write-to-string (load-file file (filename-to-modulename file)))))
+
+
+;;;; background activities
+
+(defslimefun operator-arglist (op _)
+  (try-or (fun ()
+            (let ((value (str-eval op (buffer-module))))
+              (if (isa? value <fun>)
+                  (write-to-string value)
+                  'nil)))
+          'nil))
+
+
+;;;; M-.
+
+(defslimefun find-definitions-for-emacs (name|<str>)
+  (match (parse-symbol name)
+    ((,sym ,modname)
+     (def env (module-target-environment (runtime-module modname)))
+     (def b (find-binding sym env))
+     (cond (b (find-binding-definitions b))
+           (#t 'nil)))))
+
+(df parse-symbol (name|<str> => <lst>)
+  (if (mem? name #\:)
+      (match (split name #\:)
+        ((,module ,name) (lst (as-sym name) (as-sym module))))
+      (lst (as-sym name) (module-name (buffer-module)))))
+
+(df find-binding-definitions (b|<binding>)
+  (def value (case (binding-kind b)
+               (('runtime) (loc-val (binding-locative b)))
+               (('global) (let ((box (binding-global-box b)))
+                            (and box (global-box-value box))))
+               (('macro) (binding-info b))
+               (#t (error "unknown binding kind %=" (binding-kind b)))))
+  (map (fun (o) 
+         (def loc (emacs-src-loc o))
+         `(,(write-to-string (dspec o))
+           ,(or loc `(:error "no src-loc available"))))
+       (defining-objects value)))
+
+(dm defining-objects (o => <lst>) '())
+(dm defining-objects (o|<fun> => <lst>) (lst o))
+(dm defining-objects (o|<gen> => <lst>) (pair o (fun-mets o)))
+
+(dm emacs-src-loc (o|<fun>) 
+  (def loc (fun-src-loc o))
+  (and loc `(:location (:file ,(simplify-filename
+                                (find-goo-file-in-path
+                                 (module-name-to-relpath (src-loc-file loc))
+                                 *module-search-path*)))
+                       (:line ,(src-loc-line loc))
+                       ())))
+
+(dm dspec (f|<fun>)
+  (cond ((fun-name f) 
+         `(,(if (isa? f <gen>) 'dg 'dm) ,(fun-name f) ,@(dspec-arglist f)))
+        (#t f)))
+
+(df dspec-arglist (f|<fun>)
+  (map2 (fun (name class) 
+          (cond ((= class <any>) name)
+                ((isa? class <class>)
+                 `(,name ,(class-name class)))
+                (#t `(,name ,class))))
+        (fun-info-names (fun-info f))
+        (sig-specs (fun-sig f))))
+
+(defslimefun buffer-first-change (filename) 'nil)
+
+
+;;;; apropos
+
+(defslimefun apropos-list-for-emacs 
+    (pattern only-external? case-sensitive? package)
+  (def matches (fab <tab> 100))
+  (do-all-bindings 
+   (fun (b) 
+     (when (finds (binding-name-str b) pattern)
+       (set (elt matches
+                 (cat-sym (binding-name b)
+                          (module-name (binding-module b))))
+            b))))
+  (set matches (sort-by (packing-as <vec> (for ((b matches)) (pack b)))
+                        (fun (x y) 
+                          (< (binding-name x) 
+                             (binding-name y)))))
+  (map (fun (b) 
+         `(:designator 
+           ,(cat (sym-name (module-name (binding-module b))) ":"
+                 (binding-name-str b)
+                 "\tkind: " (sym-name (binding-kind b)))))
+       (as <lst> matches)))
+
+(df do-all-bindings (f|<fun>)
+  (for ((module (%module-loader-modules (runtime-module-loader))))
+    (do f (environment-bindings (module-target-environment module)))))
+
+(dm < (s1|<str> s2|<str> => <log>)
+  (let ((l1 (len s1)) (l2 (len s2)))
+    (rep loop ((i 0))
+      (cond ((= i l1) (~= l1 l2))
+            ((= i l2) #f)
+            ((< (elt s1 i) (elt s2 i)) #t)
+            ((= (elt s1 i) (elt s2 i)) (loop (1+ i)))
+            (#t #f)))))
+
+(df %binding-info (name|<sym> module|<sym>)
+  (binding-info
+   (find-binding 
+    name (module-target-environment (runtime-module module)))))
+
+
+;;;; completion
+
+(defslimefun simple-completions (pattern|<str> package)
+  (def matches (lst))
+  (for ((b (environment-bindings (module-target-environment (buffer-module)))))
+    (when (prefix? (binding-name-str b) pattern)
+      (pushf matches b)))
+  (def strings (map binding-name-str matches))
+  `(,strings ,(cond ((nul? strings) pattern)
+                    (#t (fold+ common-prefix strings)))))
+
+(df common-prefix (s1|<seq> s2|<seq>)
+  (let ((limit (min (len s1) (len s2))))
+    (rep loop ((i 0))
+      (cond ((or (= i limit)
+                 (~= (elt s1 i) (elt s2 i)))
+             (sub s1 0 i))
+            (#t (loop (1+ i)))))))
+
+(defslimefun list-all-package-names (_|...)
+  (map sym-name (keys (all-modules))))
+
+(df all-modules () (%module-loader-modules (runtime-module-loader)))
+
+
+;;;; Macroexpand
+
+(defslimefun swank-macroexpand-1 (str|<str>)
+  (write-to-string
+   (%ast-macro-expand (read-from-string str) 
+                      (module-target-environment (buffer-module))
+                      #f)))
+
+
+;;;; streams
+
+(dc <slime-out-port> (<out-port>))
+(dp @socket (<slime-out-port> => <port>))
+(dp! @buf-len (<slime-out-port> => <int>) 0)
+(dp @buf (<slime-out-port> => <vec>) (new <vec>))
+(dp! @timestamp (<slime-out-port> => <int>) 0)
+
+(dm recurring-write (port|<out-port> x|<slime-out-port> d|<int> recur|<fun>)
+  (msg port "#{%s buf-len: %s}" (class-name-str x) (@buf-len x)))
+
+(dm put (p|<slime-out-port> c|<chr>)
+  (add! (@buf p) c)
+  (incf (@buf-len p))
+  (maybe-flush p (= c #\newline)))
+
+(dm puts (p|<slime-out-port> s|<str>)
+  (add! (@buf p) s)
+  (incf (@buf-len p) (len s))
+  (maybe-flush p (mem? s #\newline)))
+
+(df maybe-flush (p|<slime-out-port> newline?|<log>)
+  (and (or (> (@buf-len p) 4000) newline?)
+       (> (- (current-time) (@timestamp p)) 100000)
+       (force-out p)))
+
+(dm force-out (p|<slime-out-port>)
+  (unless (zero? (@buf-len p))
+    (dispatch-event `(:write-string ,(%buf-to-str (@buf p))) (@socket p))
+    (set (@buf-len p) 0)
+    (zap! (@buf p)))
+  (set (@timestamp p) (current-time)))
+
+(df %buf-to-str (buf|<vec>)
+  (packing-as <str>
+    (for ((i buf))
+      (cond ((isa? i <str>) (for ((c i)) (pack c)))
+            (#t (pack i))))))
+
+(dc <slime-in-port> (<in-port>))
+(dp @socket (<slime-in-port> => <port>))
+(dp! @idx (<slime-in-port> => <int>) 0)
+(dp! @buf (<slime-in-port> => <str>) "")
+
+(df receive-input (p|<slime-in-port>)
+  (dispatch-event `(:read-string ,0) (@socket p)))
+
+(dm get (p|<slime-in-port> => <chr>)
+  (cond ((< (@idx p) (len (@buf p)))
+         (def c (elt (@buf p) (@idx p)))
+         (incf (@idx p))
+         c)
+        (#t 
+         (def input (receive-input p))
+         (cond ((zero? (len input)) (eof-object))
+               (#t (set (@buf p) input)
+                   (set (@idx p) 0)
+                   (get p))))))
+
+(dm ready? (p|<slime-in-port> => <log>) (< (@idx p) (len (@buf p))))
+
+(dm peek (p|<slime-in-port> => <chr>)
+  (let ((c (get p)))
+    (unless (eof-object? c)
+      (decf (@idx p)))
+    c))
+
+
+;;;; Message encoding
+
+(df decode-message (port|<in-port>)
+  (read-from-string (get-block port (read-message-length port))))
+
+(df read-message-length (port) 
+  (or (str-to-num (cat "#x" (get-block port 6)))
+      (error "can't parse message length")))
+
+(df encode-message (message port)
+  (let ((string (dlet ((*max-print-length* 1000000)
+                       (*max-print-depth* 1000000))
+                  (write-to-string message))))
+    (puts port (encode-message-length (len string)))
+    (puts port string)
+    (force-out port)))
+
+(df encode-message-length (n)
+  (loc ((hex (byte) 
+             (if (< byte #x10) 
+                 (cat "0" (num-to-str-base byte 16))
+                 (num-to-str-base byte 16)))
+        (byte (i) (hex (& (>> n (* i 8)) 255))))
+    (cat (byte 2) (byte 1) (byte 0))))
+
+
+;;;; semi general utilities
+
+;; Return the name of O's class as string.
+(df class-name-str (o => <str>) (sym-name (class-name (class-of o))))
+
+(df binding-name-str (b|<binding> => <str>) (sym-name (binding-name b)))
+
+(df as-sym (str|<str>) (as <sym> str))
+
+;; Replace '//' in the middle of a filename with with a '/'
+(df simplify-filename (str|<str> => <str>)
+  (match (pathname-to-components str)
+    ((,hd ,@tl) 
+     (components-to-pathname (cons hd (del-vals tl 'root))))))
+
+;; Execute BODY and only if BODY exits abnormally execute RECOVER.
+(df try-recover (body recover)
+  (let ((ok #f))
+    (fin (let ((val (body)))
+           (set ok #t)
+           val)
+      (unless ok 
+        (recover)))))
+
+;; like CL's IGNORE-ERRORS but return VALUE in case of an error. 
+(df try-or (body|<fun> value)
+  (esc ret  
+    (try <error> (fun (condition resume) (ret value))
+      (body))))
+
+(df simple-restart (type msg body)
+  (esc restart
+    (try ((type type) (description msg))
+        (fun (c r) (restart #f))
+      (body))))
+
+(df safe-write-to-string (o)
+  (esc ret  
+    (try <error> (fun (c r) 
+                   (ret (cat "#<error during write " (class-name-str o) ">")))
+      (write-to-string o))))
+
+;; Read a string of length COUNT.
+(df get-block (port|<in-port> count|<int> => <str>)
+  (packing-as <str> 
+    (for ((i (below count)))
+      (let ((c (get port)))
+        (cond ((eof-object? c) 
+               (error "Premature EOF (read %d of %d)" i count))
+              (#t (pack c)))))))
+
+
+;;;; import some internal bindings
+
+(df %lookup (name|<sym> module|<sym>)
+  (loc-val 
+   (binding-locative 
+    (find-binding 
+     name (module-target-environment (runtime-module module))))))
+
+(d. %handler-info           (%lookup 'handler-info 'goo/conditions))
+(d. %handler-condition-type (%lookup 'handler-condition-type 'goo/conditions))
+(d. %do-handlers-of-type    (%lookup 'do-handlers-of-type 'goo/conditions))
+(d. %module-loader-modules  (%lookup 'module-loader-modules 'eval/module))
+(d. %ast-macro-expand       (%lookup 'ast-macro-expand 'eval/ast))
+
+
+;;;; low level socket stuff
+;;; this shouldn't be here
+
+#{ 
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <netinet/in.h>
+#include <errno.h>
+#include <string.h>
+#include <stdlib.h>
+#include <sys/time.h>
+
+/* convert a goo number to a C long */
+static long g2i (P o) { return untag (o); }
+
+static int
+set_reuse_address (int socket, int value) {
+  return setsockopt (socket, SOL_SOCKET, SO_REUSEADDR, &value, sizeof value);
+}
+
+static int
+bind_socket (int socket, int port) {
+  struct sockaddr_in addr;
+  addr.sin_family = AF_INET;
+  addr.sin_port = htons (port);
+  addr.sin_addr.s_addr = htonl (INADDR_ANY);
+  return bind (socket, (struct sockaddr *)&addr, sizeof addr);
+}
+
+static int
+local_port (int socket) {
+  struct sockaddr_in addr;
+  socklen_t len = sizeof addr;
+  int code = getsockname (socket, (struct sockaddr *)&addr, &len);
+  return (code == -1) ? -1 : ntohs (addr.sin_port);
+}
+
+static int
+c_accept (int socket) {
+  struct sockaddr_in addr;
+  socklen_t len = sizeof addr;
+  return accept (socket, (struct sockaddr *)&addr, &len);
+}
+
+static P tup3 (P e0, P e1, P e2) {
+  P tup = YPPtfab ((P)3, YPfalse);
+  YPtelt_setter (e0, tup, (P)0);
+  YPtelt_setter (e1, tup, (P)1);
+  YPtelt_setter (e2, tup, (P)2);
+  return tup;
+}
+
+static P
+current_time (void) {
+  struct timeval timeval;
+  int code = gettimeofday (&timeval, NULL);
+  if (code == 0) {
+     return tup3 (YPib ((P)(timeval.tv_sec >> 24)), 
+                  YPib ((P)(timeval.tv_sec & 0xffffff)),
+                  YPib ((P)(timeval.tv_usec)));     
+  } else return YPib ((P)errno);
+}
+}
+
+;; Return the current time in microsecs
+(df current-time (=> <int>)
+  (def t #eg{ current_time () })
+  (cond ((isa? t <int>) (error "%s" (strerror t)))
+        (#t (+ (* (+ (<< (1st t) 24) 
+                     (2nd t)) 
+                  1000000) 
+               (3rd t)))))
+
+(dm strerror (e|<int> => <str>)   #es{ strerror (g2i ($e)) })
+(dm strerror (e|(t= #f) => <str>) #es{ strerror (errno) })
+
+(df checkr (value|<int>)
+  (cond ((~== value -1) value)
+        (#t (error "%s" (strerror #f)))))
+
+(df create-socket (port|<int> => <int>)
+  (let ((socket (checkr #ei{ socket (PF_INET, SOCK_STREAM, 0) })))
+    (checkr #ei{ set_reuse_address (g2i ($socket), 1) })
+    (checkr #ei{ bind_socket (g2i ($socket), g2i ($port)) })
+    (checkr #ei{ listen (g2i ($socket), 1)})
+    socket))
+
+(df %local-port (fd|<int>) (checkr #ei{ local_port (g2i ($fd)) }))
+(df %close (fd|<int>) (checkr #ei{ close (g2i ($fd)) }))
+
+(dc <fd-io-port> (<in-port> <out-port>))
+(dp @fd (<fd-io-port> => <int>))
+(dp @in (<fd-io-port> => <file-in-port>))
+(dp @out (<fd-io-port> => <file-out-port>))
+
+(dm recurring-write (port|<out-port> x|<fd-io-port> d|<int> recur|<fun>)
+  (msg port "#{%s fd: %s}" (class-name-str x) (@fd x)))
+
+(dm get  (port|<fd-io-port> => <chr>) (get (@in port)))
+
+(dm puts      (port|<fd-io-port> s|<str>) (puts (@out port) s))
+(dm force-out (port|<fd-io-port>)         (force-out (@out port)))
+
+(dm fdopen (fd|<int> type|(t= <fd-io-port>) => <fd-io-port>)
+  (new <fd-io-port> @fd fd
+    @in (new <file-in-port> port-handle (%fdopen fd "r"))
+    @out (new <file-out-port> port-handle (%fdopen fd "w"))))
+
+(df %fdopen (fd|<int> mode|<str> => <loc>)
+  (def addr #ei{ fdopen (g2i ($fd), @mode) })
+  (when (zero? addr)
+    (error "fdopen failed: %s" (strerror #f)))
+  (%lb (%iu addr)))
+
+(df accept (socket|<int> => <fd-io-port>)
+  (fdopen (checkr #ei{ c_accept (g2i ($socket)) }) <fd-io-port>))
+
+(export
+  start-swank
+  create-server)
+
+;;; swank-goo.goo ends here

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-ikarus.ss

@@ -0,0 +1,86 @@
+;; swank-larceny.scm --- Swank server for Ikarus
+;;
+;; License: Public Domain
+;; Author: Helmut Eller
+;;
+;; In a shell execute:
+;;   ikarus swank-ikarus.ss
+;; and then `M-x slime-connect' in Emacs.
+;;
+
+(library (swank os)
+    (export getpid make-server-socket accept local-port close-socket)
+    (import (rnrs)
+	    (only (ikarus foreign) make-c-callout dlsym dlopen
+		  pointer-set-c-long! pointer-ref-c-unsigned-short
+		  malloc free pointer-size)
+	    (rename (only (ikarus ipc) tcp-server-socket accept-connection
+			  close-tcp-server-socket)
+		    (tcp-server-socket make-server-socket)
+		    (close-tcp-server-socket close-socket))
+	    (only (ikarus)
+		  struct-type-descriptor
+		  struct-type-field-names
+		  struct-field-accessor)
+	    )
+
+ (define libc (dlopen))
+ (define (cfun name return-type arg-types)
+   ((make-c-callout return-type arg-types) (dlsym libc name)))
+
+ (define getpid (cfun "getpid" 'signed-int '()))
+
+ (define (accept socket codec)
+   (let-values (((in out) (accept-connection socket)))
+     (values (transcoded-port in (make-transcoder codec))
+	     (transcoded-port out (make-transcoder codec)))))
+
+ (define (socket-fd socket)
+   (let ((rtd (struct-type-descriptor socket)))
+     (do ((i 0 (+ i 1))
+	  (names (struct-type-field-names rtd) (cdr names)))
+	 ((eq? (car names) 'fd) ((struct-field-accessor rtd i) socket)))))
+
+ (define sockaddr_in/size 16)
+ (define sockaddr_in/sin_family 0)
+ (define sockaddr_in/sin_port 2)
+ (define sockaddr_in/sin_addr 4)
+
+ (define (local-port socket)
+   (let* ((fd (socket-fd socket))
+	  (addr (malloc sockaddr_in/size))
+	  (size (malloc (pointer-size))))
+     (pointer-set-c-long! size 0 sockaddr_in/size)
+     (let ((code (getsockname fd addr size))
+	   (port (ntohs (pointer-ref-c-unsigned-short 
+			 addr sockaddr_in/sin_port))))
+       (free addr)
+       (free size)
+       (cond ((= code -1) (error "getsockname failed"))
+	     (#t port)))))
+
+ (define getsockname 
+   (cfun "getsockname" 'signed-int '(signed-int pointer pointer)))
+
+ (define ntohs (cfun "ntohs" 'unsigned-short '(unsigned-short)))
+
+ )
+
+
+(library (swank sys)
+    (export implementation-name eval-in-interaction-environment)
+    (import (rnrs) 
+	    (rnrs eval)
+	    (only (ikarus) interaction-environment))
+
+ (define (implementation-name) "ikarus")
+
+ (define (eval-in-interaction-environment form)
+   (eval form (interaction-environment)))
+
+ )
+
+(import (only (ikarus) load))
+(load "swank-r6rs.scm")
+(import (swank))
+(start-server #f)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-jolt.k

@@ -0,0 +1,998 @@
+;;; swank-jolt.k --- Swank server for Jolt                         -*- goo -*-
+;;
+;; 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).
+
+;;; Commentary:
+;;
+;; Jolt/Coke is a Lisp-like language wich operates at the semantic level of
+;; C, i.e. most objects are machine words and memory pointers.  The
+;; standard boot files define an interface to Id Smalltalk.  So we can
+;; also pretend to do OOP, but we must be careful to pass properly
+;; tagged pointers to Smalltalk.
+;;
+;; This file only implements a minimum of SLIME's functionality.  We
+;; install a handler with atexit(3) to invoke the debugger.  This way
+;; we can stop Jolt from terminating the process on every error.
+;; Unfortunately, the backtrace doesn't contain much information and
+;; we also have no error message (other than the exit code).  Jolt
+;; usually prints some message to stdout before calling exit, so you
+;; have to look in the *inferior-lisp* buffer for hints.  We do
+;; nothing (yet) to recover from SIGSEGV.
+
+;;; Installation
+;;
+;; 1. Download and build cola.  See <http://piumarta.com/software/cola/>.  
+;;    I used the svn version:
+;;       svn co http://piumarta.com/svn2/idst/trunk idst
+;; 2. Add something like this to your .emacs:
+;;    
+;;  (add-to-list 'slime-lisp-implementations
+;;               '(jolt (".../idst/function/jolt-burg/main" 
+;;                       "boot.k" ".../swank-jolt.k" "-") ; note the "-"
+;;                      :init jolt-slime-init
+;;                      :init-function slime-redirect-inferior-output)
+;;  (defun jolt-slime-init (file _) (format "%S\n" `(start-swank ,file)))
+;;  (defun jolt () (interactive) (slime 'jolt))
+;;
+;; 3. Use `M-x jolt' to start it.
+;;
+
+;;; Code
+
+;; In this file I use 2-3 letters for often used names, like DF or
+;; VEC, even if those names are abbreviations.  I think that after a
+;; little getting used to, this style is just as readable as the more
+;; traditional DEFUN and VECTOR.  Shorter names make it easier to
+;; write terse code, in particular 1-line definitions.
+
+;; `df' is like `defun' in a traditional lisp
+(syntax df 
+  (lambda (form compiler)
+    (printf "df %s ...\n" [[[form second] asString] _stringValue])
+    `(define ,[form second] (lambda ,@[form copyFrom: '2]))))
+
+;; (! args ...) is the same as [args ...] but easier to edit.
+(syntax !
+  (lambda (form compiler)
+    (cond ((== [form size] '3)
+           (if [[form third] isSymbol]
+               `(send ',[form third] ,[form second])
+               [compiler errorSyntax: [form third]]))
+          ((and [[form size] > '3]
+                (== [[form size] \\ '2] '0))
+           (let ((args [OrderedCollection new])
+                 (keys [OrderedCollection new])
+                 (i '2) (len [form size]))
+             (while (< i len)
+               (let ((key [form at: i]))
+                 (if (or [key isKeyword]
+                         (and (== i '2) [key isSymbol])) ; for [X + Y]
+                     [keys addLast: [key asString]]
+                     [compiler errorSyntax: key]))
+               [args addLast: [form at: [i + '1]]]
+               (set i [i + '2]))
+             `(send ',[[keys concatenated] asSymbol] ,[form second] ,@args)))
+          (1 [compiler errorArgumentCount: form]))))
+
+(define Integer (import "Integer"))
+(define Symbol (import "Symbol")) ;; aka. _selector
+(define StaticBlockClosure (import "StaticBlockClosure"))
+(define BlockClosure (import "BlockClosure"))
+(define SequenceableCollection (import "SequenceableCollection"))
+(define _vtable (import "_vtable"))
+(define ByteArray (import "ByteArray"))
+(define CodeGenerator (import "CodeGenerator"))
+(define TheGlobalEnvironment (import "TheGlobalEnvironment"))
+
+(df error (msg) (! Object error: msg))
+(df print-to-string (obj)
+  (let ((len '200)
+        (stream (! WriteStream on: (! String new: len))))
+    (! stream print: obj)
+    (! stream contents)))
+(df assertion-failed (exp)
+  (error (! '"Assertion failed: " , (print-to-string exp))))
+
+(syntax assert 
+  (lambda (form) 
+    `(if (not ,(! form second))
+         (assertion-failed ',(! form second)))))
+
+(df isa? (obj type) (! obj isKindOf: type))
+(df equal (o1 o2) (! o1 = o2))
+
+(define nil 0)
+(define false 0)
+(define true (! Object notNil))
+(df bool? (obj) (or (== obj false) (== obj true)))
+(df int? (obj) (isa? obj Integer))
+
+;; In this file the convention X>Y is used for operations that convert
+;; X-to-Y.  And _ means "machine word".  So _>int is the operator that
+;; converts a machine word to an Integer.
+
+(df _>int (word) (! Integer value_: word))
+(df int>_ (i) (! i _integerValue))
+
+;; Fixnum operators.  Manual tagging/untagging would probably be more
+;; efficent than invoking methods.
+
+(df fix? (obj) (& obj 1))
+(df _>fix (n) (! SmallInteger value_: n))
+(df fix>_ (i) (! i _integerValue))
+(df fx+ (fx1 fx2) (! fx1 + fx2))
+(df fx* (fx1 fx2) (! fx1 * fx2))
+(df fx1+ (fx) (! fx + '1))
+(df fx1- (fx) (! fx - '1))
+
+(df str? (obj) (isa? obj String))
+(df >str (o) (! o asString))
+(df str>_ (s) (! s _stringValue))
+(df _>str (s) (! String value_: s))
+(df sym? (obj) (isa? obj Symbol))
+(df seq? (obj) (isa? obj SequenceableCollection))
+(df array? (obj) (isa? obj Array))
+(df len (obj) (! obj size))
+(df len_ (obj) (! (! obj size) _integerValue))
+(df ref (obj idx) (! obj at: idx))
+(df set-ref (obj idx elt) (! obj at: idx put: elt))
+(df first (obj) (! obj first))
+(df second (obj) (! obj second))
+
+(df puts (string stream) (! stream nextPutAll: string))
+
+(define _GC_base (dlsym "GC_base"))
+
+;; Is ADDR a pointer to a heap allocated object?  The Boehm GC nows
+;; such things.  This is useful for debugging, because we can quite
+;; safely (i.e. without provoking SIGSEGV) access such addresses.
+(df valid-pointer? (addr) 
+  (let ((ptr (& addr (~ 1))))
+    (and (_GC_base ptr)
+         (_GC_base (long@ ptr -1)))))
+
+;; Print OBJ as a Lisp printer would do.
+(df prin1 (obj stream)
+  (cond ((fix? obj) (! stream print: obj))
+        ((== obj nil) (puts '"nil" stream))
+        ((== obj false) (puts '"#f" stream))
+        ((== obj true) (puts '"#t" stream))
+        ((not (valid-pointer? obj)) 
+         (begin (puts '"#<w " stream)
+                (prin1 (_>int obj) stream)
+                (puts '">" stream)))
+        ((int? obj) (! stream print: obj))
+        ((sym? obj) (puts (>str obj) stream))
+        ((isa? obj StaticBlockClosure)
+         (begin (puts '"#<fun /" stream)
+                (! stream print: (! obj arity))
+                (puts '"#>" stream)))
+        ((and (str? obj) (len obj))
+         (! obj printEscapedOn: stream delimited: (ref '"\"" '0)))
+        ((and (array? obj) (len obj))
+         (begin (puts '"(" stream)
+                (let ((max (- (len_ obj) 1)))
+                  (for (i 0 1 max)
+                    (prin1 (ref obj (_>fix i)) stream)
+                    (if (!= i max)
+                        (puts '" " stream))))
+                (puts '")" stream)))
+        ((and (isa? obj OrderedCollection) (len obj))
+         (begin (puts '"#[" stream)
+                (let ((max (- (len_ obj) 1)))
+                  (for (i 0 1 max)
+                    (prin1 (ref obj (_>fix i)) stream)
+                    (if (!= i max)
+                        (puts '" " stream))))
+                (puts '"]" stream)))
+        (true 
+         (begin (puts '"#<" stream)
+                (puts (! obj debugName) stream)
+                (puts '">" stream))))
+  obj)
+
+(df print (obj)
+  (prin1 obj StdOut)
+  (puts '"\n" StdOut))
+
+(df prin1-to-string (obj)
+  (let ((len '100)
+        (stream (! WriteStream on: (! String new: len))))
+    (prin1 obj stream)
+    (! stream contents)))
+
+;;(df %vable-tally (_vtable) (long@ _vtable))
+(df cr () (printf "\n"))
+(df print-object-selectors (obj)
+  (let ((vtable (! obj _vtable))
+        (tally (long@ vtable 0))
+        (bindings (long@ vtable 1)))
+    (for (i 1 1 tally)
+      (print (long@ (long@ bindings i)))
+      (cr))))
+
+(df print-object-slots (obj)
+  (let ((size (! obj _sizeof))
+        (end (+ obj size)))
+    (while (< obj end)
+      (print (long@ obj))
+      (cr)
+      (incr obj 4))))
+
+(df intern (string) (! Symbol intern: string))
+
+;; Jolt doesn't seem to have an equivalent for gensym, but it's damn
+;; hard to write macros without it.  So here we adopt the conventions
+;; that symbols which look like ".[0-9]+" are reserved for gensym and
+;; shouldn't be used for "user visible variables".
+(define gensym-counter 0)
+(df gensym ()
+  (set gensym-counter (+ gensym-counter 1))
+  (intern (! '"." , (>str (_>fix gensym-counter)))))
+
+;; Surprisingly, SequenceableCollection doesn't have a indexOf method.
+;; So we even need to implement such mundane things.
+(df index-of (seq elt)
+  (let ((max (len seq))
+        (i '0))
+    (while (! i < max)
+      (if (equal (ref seq i) elt)
+          (return i)
+          (set i (! i + '1))))
+    nil))
+
+(df find-dot (array) (index-of array '.))
+
+;; What followes is the implementation of the pattern matching macro MIF.
+;; The syntax is (mif (PATTERN EXP) THEN ELSE).
+;; The THEN-branch is executed if PATTERN matches the value produced by EXP.
+;; ELSE gets only executed if the match failes.
+;; A pattern can be
+;;  1) a symbol, which matches all values, but also binds the variable to the
+;;     value
+;;  2) (quote LITERAL), matches if the value is `equal' to LITERAL.
+;;  3) (PS ...) matches sequences, if the elements match PS.
+;;  4) (P1 ... Pn . Ptail) matches if P1 ... Pn match the respective elements
+;;                         at indices 1..n and if Ptail matches the rest
+;;                         of the sequence
+;; Examples:
+;;   (mif (x 10) x 'else) => 10
+;;   (mif ('a 'a) 'then 'else) => then
+;;   (mif ('a 'b) 'then 'else) => else
+;;   (mif ((a b) '(1 2)) b 'else) => 2
+;;   (mif ((a . b) '(1 2)) b 'else) => '(2)
+;;   (mif ((. x) '(1 2)) x 'else) => '(1 2)
+
+(define mif% 0) ;; defer
+(df mif%array (compiler pattern i value then fail)
+  ;;(print `(mif%array ,pattern ,i ,value))
+  (cond ((== i (len_ pattern)) then)
+        ((== (ref pattern (_>fix i)) '.)
+         (begin
+          (if (!= (- (len_ pattern) 2) i)
+              (begin 
+               (print pattern)
+               (! compiler error: (! '"dot in strange position: "
+                                     , (>str (_>fix i))))))
+          (mif% compiler 
+                (ref pattern (_>fix (+ i 1)))
+                `(! ,value copyFrom: ',(_>fix i))
+                then fail)))
+        (true 
+         (mif% compiler
+               (ref pattern (_>fix i))
+               `(ref ,value ',(_>fix i))
+               (mif%array compiler pattern (+ i 1) value then fail)
+               fail))))
+
+(df mif% (compiler pattern value then fail)
+  ;;(print `(mif% ,pattern ,value ,then))
+  (cond ((== pattern '_) then)
+        ((== pattern '.) (! compiler errorSyntax: pattern))
+        ((sym? pattern) 
+         `(let ((,pattern ,value)) ,then))
+        ((seq? pattern)
+         (cond ((== (len_ pattern) 0)
+                `(if (== (len_ ,value) 0) ,then (goto ,fail)))
+               ((== (first pattern) 'quote)
+                (begin
+                 (if (not (== (len_ pattern) 2))
+                     (! compiler errorSyntax: pattern))
+                 `(if (equal ,value ,pattern) ,then (goto ,fail))))
+               (true 
+                (let ((tmp (gensym)) (tmp2 (gensym))
+                      (pos (find-dot pattern)))
+                  `(let ((,tmp2 ,value)
+                         (,tmp ,tmp2))
+                     (if (and (seq? ,tmp)
+                              ,(if (find-dot pattern)
+                                   `(>= (len ,tmp) 
+                                        ',(_>fix (- (len_ pattern) 2)))
+                                   `(== (len ,tmp) ',(len pattern))))
+                         ,(mif%array compiler pattern 0 tmp then fail)
+                         (goto ,fail)))))))
+        (true (! compiler errorSyntax: pattern))))
+
+(syntax mif
+  (lambda (node compiler)
+    ;;(print `(mif ,node))
+    (if (not (or (== (len_ node) 4)
+                 (== (len_ node) 3)))
+        (! compiler errorArgumentCount: node))
+    (if (not (and (array? (ref node '1))
+                  (== (len_ (ref node '1)) 2)))
+        (! compiler errorSyntax: (ref node '1)))
+    (let ((pattern (first (ref node '1)))
+          (value (second (ref node '1)))
+          (then (ref node '2))
+          (else (if (== (len_ node) 4)
+                    (ref node '3)
+                    `(error "mif failed")))
+          (destination (gensym))
+          (fail (! compiler newLabel))
+          (success (! compiler newLabel)))
+      `(let ((,destination 0))
+         ,(mif% compiler pattern value 
+                `(begin (set ,destination ,then)
+                        (goto ,success))
+                fail)
+         (label ,fail)
+         (set ,destination ,else)
+         (label ,success)
+         ,destination))))
+
+;; (define *catch-stack* nil)
+;; 
+(df bar (o) (mif ('a o) 'yes 'no))
+(assert (== (bar 'a) 'yes))
+(assert (== (bar 'b) 'no))
+(df foo (o) (mif (('a) o) 'yes 'no))
+(assert (== (foo '(a)) 'yes))
+(assert (== (foo '(b)) 'no))
+(df baz (o) (mif (('a 'b) o) 'yes 'no))
+(assert (== (baz '(a b)) 'yes))
+(assert (== (baz '(a c)) 'no))
+(assert (== (baz '(b c)) 'no))
+(assert (== (baz 'a) 'no))
+(df mifvar (o) (mif (y o) y 'no))
+(assert (== (mifvar 'foo) 'foo))
+(df mifvec (o) (mif ((y) o) y 'no))
+(assert (== (mifvec '(a)) 'a))
+(assert (== (mifvec 'x) 'no))
+(df mifvec2 (o) (mif (('a y) o) y 'no))
+(assert (== (mifvec2 '(a b)) 'b))
+(assert (== (mifvec2 '(b c)) 'no))
+(assert (== (mif ((x) '(a)) x 'no) 'a))
+(assert (== (mif ((x . y) '(a b)) x 'no) 'a))
+(assert (== (mif ((x y . z) '(a b)) y 'no) 'b))
+(assert (equal (mif ((x . y) '(a b)) y 'no) '(b)))
+(assert (equal (mif ((. x) '(a b)) x 'no) '(a b)))
+(assert (equal (mif (((. x)) '((a b))) x 'no) '(a b)))
+(assert (equal (mif (((. x) . y) '((a b) c)) y 'no) '(c)))
+(assert (== (mif (() '()) 'yes 'no) 'yes))
+(assert (== (mif (() '(a)) 'yes 'no) 'no))
+
+;; Now that we have a somewhat convenient pattern matcher we can write
+;; a more convenient macro defining macro:
+(syntax defmacro
+  (lambda (node compiler)
+    (mif (('defmacro name (. args) . body) node)
+         (begin 
+          (printf "defmacro %s ...\n" (str>_ (>str name)))
+          `(syntax ,name
+             (lambda (node compiler)
+               (mif ((',name ,@args) node)
+                    (begin ,@body)
+                    (! compiler errorSyntax: node)))))
+         (! compiler errorSyntax: node))))
+
+;; and an even more convenient pattern matcher:
+(defmacro mcase (value . clauses)
+  (let ((tmp (gensym)))
+    `(let ((,tmp ,value))
+       ,(mif (() clauses) 
+             `(begin (print ,tmp) 
+                     (error "mcase failed"))
+             (mif (((pattern . body) . more) clauses)
+                  `(mif (,pattern ,tmp) 
+                        (begin ,@(mif (() body) '(0) body))
+                        (mcase ,tmp ,@more))
+                  (! compiler errorSyntax: clauses))))))
+
+;; and some traditional macros
+(defmacro when (test . body) `(if ,test (begin ,@body)))
+(defmacro unless (test . body) `(if ,test 0 (begin ,@body)))
+(defmacro or (. args)  ; the built in OR returns 1 on success.
+  (mcase args
+    (() 0)
+    ((e) e)
+    ((e1 . more)
+     (let ((tmp (gensym)))
+       `(let ((,tmp ,e1))
+          (if ,tmp ,tmp (or ,@more)))))))
+
+(defmacro dotimes_ ((var n) . body)
+  (let ((tmp (gensym)))
+    `(let ((,tmp ,n)
+	   (,var 0))
+       (while (< ,var ,tmp)
+	 ,@body
+	 (set ,var (+ ,var 1))))))
+
+(defmacro dotimes ((var n) . body)
+  (let ((tmp (gensym)))
+    `(let ((,tmp ,n)
+	   (,var '0))
+       (while (< ,var ,tmp)
+	 ,@body
+	 (set ,var (fx1+ ,var))))))
+
+;; DOVEC is like the traditional DOLIST but works on "vectors"
+;; i.e. sequences which can be indexed efficently.
+(defmacro dovec ((var seq) . body)
+  (let ((i (gensym))
+	(max (gensym))
+	(tmp (gensym)))
+    `(let ((,i 0)
+	   (,tmp ,seq)
+	   (,max (len_ ,tmp)))
+       (while (< ,i ,max)
+	 (let ((,var (! ,tmp at: (_>fix ,i))))
+	   ,@body
+	   (set ,i (+ ,i 1)))))))
+
+;; "Packing" is what Lispers usually call "collecting".
+;; The Lisp idiom  (let ((result '())) .. (push x result) .. (nreverse result))
+;; translates to   (packing (result) .. (pack x result))
+(defmacro packing ((var) . body)
+  `(let ((,var (! OrderedCollection new)))
+     ,@body
+     (! ,var asArray)))
+
+(df pack (elt packer) (! packer addLast: elt))
+
+(assert (equal (packing (p) (dotimes_ (i 2) (pack (_>fix i) p)))
+               '(0 1)))
+
+(assert (equal (packing (p) (dovec (e '(2 3)) (pack e p)))
+               '(2 3)))
+
+(assert (equal (packing (p)
+                 (let ((a '(2 3)))
+                   (dotimes (i (len a))
+                     (pack (ref a i) p))))
+               '(2 3)))
+
+;; MAPCAR (more or less)
+(df map (fun col)
+  (packing (r) 
+    (dovec (e col) 
+      (pack (fun e) r))))
+
+;; VEC allocates and initializes a new array.
+;; The macro translates (vec x y z) to `(,x ,y ,z).
+(defmacro vec (. args)
+  `(quasiquote
+    (,@(map (lambda (arg) `(,'unquote ,arg))
+            args))))
+
+(assert (equal (vec '0 '1) '(0 1)))
+(assert (equal (vec) '()))
+(assert (== (len (vec 0 1 2 3 4)) '5))
+
+;; Concatenate.
+(defmacro cat (. args) `(! (vec '"" ,@args) concatenated))
+
+(assert (equal (cat '"a" '"b" '"c") '"abc"))
+
+;; Take a vector of bytes and copy the bytes to a continuous
+;; block of memory
+(df assemble_ (col) (! (! ByteArray withAll: col) _bytes))
+
+;; Jolt doesn't seem to have catch/throw or something equivalent.
+;; Here I use a pair of assembly routines as substitue.
+;; (catch% FUN) calls FUN with the current stack pointer.
+;; (throw% VALUE K) unwinds the stack to K and then returns VALUE.
+;; catch% is a bit like call/cc.
+;;
+;; [Would setjmp/longjmp work from Jolt? or does setjmp require
+;;  C-compiler magic?]
+;; [I figure Smalltalk has a way to do non-local-exits but, I don't know
+;;  how to use that in Jolt.]
+;;
+(define catch%
+  (assemble_
+   '(0x55                               ; push   %ebp
+     0x89 0xe5                          ; mov    %esp,%ebp
+     0x54                               ; push   %esp
+     0x8b 0x45 0x08                     ; mov    0x8(%ebp),%eax
+     0xff 0xd0                          ; call   *%eax
+     0xc9                               ; leave  
+     0xc3                               ; ret    
+     )))
+
+(define throw%
+  (assemble_
+   `(,@'()
+     0x8b 0x44 0x24 0x04                ; mov    0x4(%esp),%eax
+     0x8b 0x6c 0x24 0x08                ; mov    0x8(%esp),%ebp
+     0xc9                               ; leave  	
+     0xc3                               ; ret    
+     )))
+
+(df bar (i  k)
+  (if (== i 0)
+      (throw% 100 k)
+      (begin
+       (printf "bar %d\n" i)
+       (bar (- i 1) k))))
+(df foo (k)
+  (printf "foo.1\n")
+  (printf "foo.2 %d\n" (bar 10 k)))
+
+;; Our way to produce closures: we compile a new little function which
+;; hardcodes the addresses of the code resp. the data-vector.  The
+;; nice thing is that such closures can be used called C function
+;; pointers.  It's probably slow to invoke the compiler for such
+;; things, so use with care.
+(df make-closure (addr state)
+  (int>_
+   (! `(lambda (a b c d)
+         (,(_>int addr) ,(_>int state) a b c d))
+      eval)))
+
+;; Return a closure which calls FUN with ARGS and the arguments
+;; that the closure was called with.  
+;; Example: ((curry printf "%d\n") 10)
+(defmacro curry (fun . args)
+  `(make-closure
+    (lambda (state a b c d)
+      ((ref state '0)
+       ,@(packing (sv)
+	   (dotimes (i (len args))
+	     (pack `(ref state ',(fx1+ i)) sv)))
+       a b c d))
+    (vec ,fun ,@args)))
+
+(df parse-closure-arglist (vars)
+  (let ((pos (or (index-of vars '|)
+                 (return nil)))
+        (cvars (! vars copyFrom: '0 to: (fx1- pos)))
+        (lvars (! vars copyFrom: (fx1+ pos))))
+    (vec cvars lvars)))
+
+;; Create a closure, to-be-closed-over variables must enumerated
+;; explicitly.  
+;; Example: ((let ((x 1)) (closure (x | y) (+ x y))) 3) => 4.
+;; The variables before the "|" are captured by the closure.
+(defmacro closure ((. vars) . body)
+  (mif ((cvars lvars) (parse-closure-arglist vars))
+       `(curry (lambda (,@cvars ,@lvars) ,@body)
+               ,@cvars)
+       (! compiler errorSyntax: vars)))
+
+;; The analog for Smalltalkish "blocks".
+(defmacro block ((. vars) . body)
+  (mif ((cvars lvars) (parse-closure-arglist vars))
+       `(! StaticBlockClosure 
+           function_: (curry (lambda (,@cvars _closure _self ,@lvars) ,@body)
+                             ,@cvars)
+           arity_: ,(len lvars))
+       (! compiler errorSyntax: vars)))
+
+(define %mkstemp (dlsym "mkstemp"))
+(df make-temp-file ()
+  (let ((name (! '"/tmp/jolt-tmp.XXXXXX" copy))
+        (fd (%mkstemp (! name _stringValue))))
+    (if (== fd -1)
+        (error "mkstemp failed"))
+    `(,fd ,name)))
+(define %unlink (dlsym "unlink"))
+(df unlink (filename) (%unlink (! filename _stringValue)))
+
+(define write (dlsym "write"))
+(df write-bytes (addr count fd)
+  (let ((written (write fd addr count)))
+    (if (!= written count)
+        (begin
+         (printf "write failed %p %d %d => %d" addr count fd written)
+         (error '"write failed")))))
+
+(define system (dlsym "system"))
+(define main (dlsym "main"))
+
+;; Starting at address ADDR, disassemble COUNT bytes.
+;; This is implemented by writing the memory region to a file
+;; and call ndisasm on it.
+(df disas (addr count)
+  (let ((fd+name (make-temp-file)))
+    (write-bytes addr count (first fd+name))
+    (let ((cmd (str>_ (cat '"ndisasm -u -o " 
+                           (>str (_>fix addr))
+                           '" " (second fd+name)))))
+      (printf "Running: %s\n" cmd)
+      (system cmd))
+    (unlink (second fd+name))))
+
+(df rep ()
+  (let ((result (! (! CokeScanner read: StdIn) eval)))
+    (puts '"=> " StdOut)
+    (print result)
+    (puts '"\n" StdOut)))
+
+;; Perhaps we could use setcontext/getcontext to return from signal
+;; handlers (or not).
+(define +ucontext-size+ 350)
+(define _getcontext (dlsym "getcontext"))
+(define _setcontext (dlsym "setcontext"))
+(df getcontext ()
+  (let ((context (malloc 350)))
+    (_getcontext context)
+    context))
+
+(define on_exit (dlsym "on_exit")) ; "atexit" doesn't work. why?
+
+(define *top-level-restart* 0)
+(define *top-level-context* 0)
+(define *debugger-hook* 0)
+
+;; Jolt's error handling strategy is charmingly simple: call exit.
+;; We invoke the SLIME debugger from an exit handler. 
+;; (The handler is registered with atexit, that's a libc function.)
+
+(df exit-handler (reason arg)
+  (printf "exit-handler 0x%x\n" reason)
+  ;;(backtrace)
+  (on_exit exit-handler nil)
+  (when *debugger-hook*
+    (*debugger-hook* `(exit ,reason)))
+  (cond (*top-level-context*
+         (_setcontext *top-level-context*))
+        (*top-level-restart*
+         (throw% reason *top-level-restart*))))
+
+(df repl ()
+  (set *top-level-context* (getcontext))
+  (while (not (! (! StdIn readStream) atEnd))
+    (printf "top-level\n")
+    (catch%
+     (lambda (k)
+       (set *top-level-restart* k)
+       (printf "repl\n")
+       (while 1
+         (rep)))))
+  (printf "EOF\n"))
+
+;; (repl)
+
+
+;;; Socket code. (How boring. Duh, should have used netcat instead.)
+
+(define strerror (dlsym "strerror"))
+
+(df check-os-code (value)
+  (if (== value -1)
+      (error (_>str (strerror (fix>_ (! OS errno)))))
+      value))
+
+;; For now just hard-code constants which usually reside in header
+;; files (just like a Forth guy would do).
+(define PF_INET 2)
+(define SOCK_STREAM 1)
+(define SOL_SOCKET 1)
+(define SO_REUSEADDR 2)
+(define socket (dlsym "socket"))
+(define setsockopt (dlsym "setsockopt"))
+
+(df set-reuse-address (sock value)
+  (let ((word-size 4)
+        (val (! Object _balloc: (_>fix word-size))))
+    (set-int@ val value)
+    (check-os-code
+     (setsockopt sock SOL_SOCKET SO_REUSEADDR val word-size))))
+
+(define sockaddr_in/size 16)
+(define sockaddr_in/sin_family 0)
+(define sockaddr_in/sin_port 2)
+(define sockaddr_in/sin_addr 4)
+(define INADDR_ANY 0)
+(define AF_INET 2)
+(define htons (dlsym "htons"))
+(define bind (dlsym "bind"))
+
+(df bind-socket (sock port)
+  (let ((addr (! OS _balloc: (_>fix sockaddr_in/size))))
+    (set-short@ (+ addr sockaddr_in/sin_family) AF_INET)
+    (set-short@ (+ addr sockaddr_in/sin_port) (htons port))
+    (set-int@ (+ addr sockaddr_in/sin_addr) INADDR_ANY)
+    (check-os-code 
+     (bind sock addr sockaddr_in/size))))
+
+(define listen (dlsym "listen"))
+
+(df create-socket (port)
+  (let ((sock (check-os-code (socket PF_INET SOCK_STREAM 0))))
+    (set-reuse-address sock 1)
+    (bind-socket sock port)
+    (check-os-code (listen sock 1))
+    sock))
+
+(define accept% (dlsym "accept"))
+(df accept (sock)
+  (let ((addr (! OS _balloc: (_>fix sockaddr_in/size)))
+        (len (! OS _balloc: 4)))
+    (set-int@ len sockaddr_in/size)
+    (check-os-code (accept% sock addr len))))
+
+(define getsockname (dlsym "getsockname"))
+(define ntohs (dlsym "ntohs"))
+(df local-port (sock)
+  (let ((addr (! OS _balloc: (_>fix sockaddr_in/size)))
+        (len (! OS _balloc: 4)))
+    (set-int@ len sockaddr_in/size)
+    (check-os-code
+     (getsockname sock addr len))
+    (ntohs (short@ (+ addr sockaddr_in/sin_port)))))
+
+(define close (dlsym "close"))
+(define _read (dlsym "read"))
+
+;; Now, after 2/3 of the file we can begin with the actual Swank
+;; server.
+
+(df read-string (fd count)
+  (let ((buffer (! String new: count))
+        (buffer_ (str>_ buffer))
+        (count_ (int>_ count))
+        (start 0))
+    (while (> (- count_ start) 0)
+      (let ((rcount (check-os-code (_read fd 
+                                          (+ buffer_ start) 
+                                          (- count_ start)))))
+        (set start (+ start rcount))))
+    buffer))
+
+;; Read and parse a message from the wire.
+(df read-packet (fd)
+  (let ((header (read-string fd '6))
+        (length (! Integer fromString: header base: '16))
+        (payload (read-string fd length)))
+    (! CokeScanner read: payload)))
+
+;; Print a messag to the wire.
+(df send-to-emacs (event fd)
+  (let ((stream (! WriteStream on: (! String new: '100))))
+    (! stream position: '6)
+    (prin1 event stream)
+    (let ((len (! stream position)))
+      (! stream position: '0)
+      (! (fx+ len '-6) printOn: stream base: '16 width: '6)
+      (write-bytes (str>_ (! stream collection)) (int>_ len) fd))))
+
+(df add-quotes (form)
+  (mcase form
+    ((fun . args)
+     `(,fun ,@(packing (s)
+                (dovec (e args) 
+                  (pack `(quote ,e) s)))))))
+
+(define sldb 0) ;defer
+
+(df eval-for-emacs (form id fd abort)
+  (let ((old-hook *debugger-hook*))
+    (mcase (catch%
+            (closure (form fd | k)
+              (set *debugger-hook* (curry sldb fd k))
+              `(ok ,(int>_ (! (add-quotes form) eval)))))
+      (('ok value) 
+       (set *debugger-hook* old-hook)
+       (send-to-emacs `(:return (:ok ,value) ,id) fd)
+       'ok)
+      (arg
+       (set *debugger-hook* old-hook)
+       (send-to-emacs `(:return (:abort) ,id) fd)
+       (throw% arg abort)))))
+
+(df process-events (fd)
+  (on_exit exit-handler nil)
+  (let ((done nil))
+    (while (not done)
+      (mcase (read-packet fd)
+        ((':emacs-rex form package thread id)
+         (mcase (catch% (closure (form id fd | abort)
+                          (eval-for-emacs form id fd abort)))
+           ('ok)
+           ;;('abort nil)
+           ('top-level)
+           (other 
+            ;;(return other) ; compiler breaks with return
+            (set done 1))))))))
+
+(df next-frame (fp)
+  (let ((next (get-caller-fp fp)))
+    (if (and (!= next fp) 
+             (<= next %top-level-fp))
+        next
+        nil)))
+
+(df nth-frame (n top)
+  (let ((fp top)
+        (i 0))
+    (while fp
+      (if (== i n) (return fp))
+      (set fp (next-frame fp))
+      (set i (+ i 1)))
+    nil))
+
+(define Dl_info/size 16)
+(define Dl_info/dli_fname 0)
+(define Dl_info/dli_sname 8)
+
+(df get-dl-sym-name (addr)
+  (let ((info (! OS _balloc: (_>fix Dl_info/size))))
+    (when (== (dladdr addr info) 0)
+      (return nil))
+    (let ((sname (long@ (+ info Dl_info/dli_sname)) )
+          (fname (long@ (+ info Dl_info/dli_fname))))
+      (cond ((and sname fname)
+             (cat (_>str sname) '" in " (_>str fname)))
+            (sname (_>str fname))
+            (fname (cat '"<??> " (_>str fname)))
+            (true nil)))))
+
+;;(get-dl-sym-name printf)
+
+(df guess-function-name (ip)
+  (let ((fname (get-function-name ip)))
+    (if fname
+        (_>str fname) 
+        (get-dl-sym-name ip))))
+
+(df backtrace>el (top_ from_ to_)
+  (let ((fp (nth-frame from_ top_))
+        (i from_))
+    (packing (bt)
+      (while (and fp (< i to_))
+        (let ((ip (get-frame-ip fp)))
+          (pack (vec (_>int i)
+                     (cat (or (guess-function-name ip) '"(no-name)")
+                          '" " ;;(>str (_>int ip))
+                          ))
+                bt))
+        (set i (+ i 1))
+        (set fp (next-frame fp))))))
+ 
+(df debugger-info (fp msg)
+  (vec `(,(prin1-to-string msg) " [type ...]" ())
+       '(("quit" "Return to top level"))
+       (backtrace>el fp 0 20)
+       '()))
+       
+(define *top-frame* 0)
+(define *sldb-quit* 0)
+
+(df debugger-loop (fd args abort)
+  (let ((fp (get-current-fp)))
+    (set *top-frame* fp)
+    (send-to-emacs `(:debug 0 1 ,@(debugger-info fp args)) fd)
+    (while 1
+      (mcase (read-packet fd)
+        ((':emacs-rex form package thread id)
+         (mcase (catch% (closure (form id fd | k)
+                          (set *sldb-quit* k)
+                          (eval-for-emacs form id fd k)
+                          'ok))
+           ('ok nil)
+           (other
+            (send-to-emacs `(:return (:abort) ,id) fd)
+            (throw% other abort))))))))
+
+(df sldb (fd abort args)
+  (let ((old-top-frame *top-frame*)
+        (old-sldb-quit *sldb-quit*))
+    (mcase (catch% (curry debugger-loop fd args))
+      (value
+       (set *top-frame* old-top-frame)
+       (set *sldb-quit* old-sldb-quit)
+       (send-to-emacs `(:debug-return 0 1 nil) fd)
+       (throw% value abort)))))
+
+(df swank:backtrace (start end)
+  (backtrace>el *top-frame* (int>_ start) (int>_ end)))
+ 
+(df sldb-quit ()
+  (assert *sldb-quit*)
+  (throw% 'top-level *sldb-quit*))
+
+(df swank:invoke-nth-restart-for-emacs (...) (sldb-quit))
+(df swank:throw-to-toplevel (...) (sldb-quit))
+
+(df setup-server (port announce)
+  (let ((sock (create-socket port)))
+    (announce sock)
+    (let ((client (accept sock)))
+      (process-events client)
+      (close client))
+    (printf "Closing socket: %d %d\n" sock (local-port sock))
+    (close sock)))
+
+(df announce-port (sock)
+  (printf "Listening on port: %d\n" (local-port sock)))
+
+(df create-server (port) (setup-server port announce-port))
+
+(df write-port-file (filename sock) 
+  (let ((f (! File create: filename)))
+    (! f write: (print-to-string (_>int (local-port sock))))
+    (! f close)))
+
+(df start-swank (port-file)
+  (setup-server 0 (curry write-port-file (_>str port-file))))
+
+(define getpid (dlsym "getpid"))
+(df swank:connection-info ()
+  `(,@'()
+    :pid ,(_>int (getpid))
+    :style nil
+    :lisp-implementation (,@'()
+                          :type "Coke" 
+                          :name "jolt" 
+                          :version ,(! CodeGenerator versionString))
+    :machine (:instance "" :type ,(! OS architecture) :version "")
+    :features ()
+    :package (:name "jolt" :prompt "jolt")))
+
+(df swank:listener-eval (string)
+  (let ((result (! (! CokeScanner read: string) eval)))
+    `(:values ,(prin1-to-string (if (or (fix? result) 
+					(and (valid-pointer? result)
+					     (int? result)))
+				    (int>_ result)
+				    result))
+	      ,(prin1-to-string result))))
+
+(df swank:interactive-eval (string)
+  (let ((result (! (! CokeScanner read: string) eval)))
+    (cat '"=> " (prin1-to-string (if (or (fix? result)
+                                         (and (valid-pointer? result)
+                                              (int? result)))
+                                     (int>_ result)
+                                     result))
+         '", " (prin1-to-string result))))
+
+(df swank:operator-arglist () nil)
+(df swank:buffer-first-change () nil)
+(df swank:create-repl (_) '("jolt" "jolt"))
+
+(df min (x y) (if (<= x y) x y))
+
+(df common-prefix2 (e1 e2)
+  (let ((i '0)
+        (max (min (len e1) (len e2))))
+    (while (and (< i max)
+                (== (ref e1 i) (ref e2 i)))
+      (set i (fx1+ i)))
+    (! e1 copyFrom: '0 to: (fx1- i))))
+
+(df common-prefix (seq)
+  (mcase seq
+    (() nil)
+    (_
+     (let ((prefix (ref seq '0)))
+       (dovec (e seq)
+         (set prefix (common-prefix2 prefix e)))
+       prefix))))
+
+(df swank:simple-completions (prefix _package)
+  (let ((matches (packing (s)
+                   (dovec (e (! TheGlobalEnvironment keys))
+                     (let ((name (>str e)))
+                       (when (! name beginsWith: prefix)
+                         (pack name s)))))))
+    (vec matches (or (common-prefix matches) prefix))))
+
+
+;; swank-jolt.k ends here

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)))

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-mit-scheme.scm

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

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/swank-mlworks.sml

@@ -0,0 +1,348 @@
+(* swank-mlworks.sml -- SWANK server for MLWorks
+ *
+ * This code has been placed in the Public Domain.
+ *)
+
+(* This is an experiment to see how the interfaces/modules would look
+ * in a language with a supposedly "good" module system.
+ *
+ * MLWorks is probably the only SML implementation that tries to
+ * support "interactive programming".  Since MLWorks wasn't maintained
+ * the last 15 or so years, big chunks of the SML Basis Library are
+ * missing or not the way as required by the standard.  That makes it
+ * rather hard to do anything; it also shows that MLWorks hasn't been
+ * "used in anger" for a long time.
+ *)
+
+structure Swank = struct
+
+    structure Util = struct
+	fun utf8ToString (v:Word8Vector.vector) : string = Byte.bytesToString v
+	fun stringToUtf8 s = Byte.stringToBytes s
+      end
+
+    structure Map = struct
+	datatype ('a, 'b) map = Alist of {list: ('a * 'b) list ref,
+					  eq: ('a * 'a) -> bool}
+
+	fun stringMap () =
+	    Alist {list = ref [],
+		   eq = (fn (x:string,y:string) => x = y)}
+
+
+	fun lookup (Alist {list, eq}, key) =
+	    let fun search [] = NONE
+		  | search ((key', value) :: xs) =
+		    if eq (key', key) then SOME value
+		    else search xs
+	    in search (!list)
+	    end
+
+	fun put (Alist {list, eq}, key, value) =
+	    let val l = (key, value) :: (!list)
+	    in list := l
+	    end
+
+      end
+
+    structure CharBuffer = struct
+	local
+	    structure C = CharArray
+	    datatype buffer = B of {array : C.array ref,
+				    index: int ref}
+	in
+
+	fun new hint = B {array = ref (C.array (hint, #"\000")),
+			  index = ref 0}
+
+	fun append (buffer as B {array, index}, char) =
+	    let val a = !array
+		val i = !index
+		val len = C.length a
+	    in if i < len then
+		   (C.update (a, i, char);
+		    index := i + 1;
+		    ())
+	       else let val aa = C.array (2 * len, #"\000")
+			fun copy (src, dst) =
+			    let val len = C.length src
+				fun loop i =
+				    if i = len then ()
+				    else (C.update (dst, i, C.sub (src, i));
+					  loop (i + 1))
+			    in loop 0 end
+		    in copy (a, aa);
+		       C.update (aa, i, char);
+		       array := aa;
+		       index := i + 1;
+		       ()
+		    end
+	    end
+
+	fun toString (B {array, index}) =
+	    let val a = !array
+		val i = !index
+	    in CharVector.tabulate (i, fn i => C.sub (a, i)) end
+
+	end
+
+      end
+
+
+    structure Sexp = struct
+	structure Type = struct
+	    datatype sexp = Int of int
+			  | Str of string
+			  | Lst of sexp list
+			  | Sym of string
+			  | QSym of string * string
+			  | T
+			  | Nil
+			  | Quote
+	  end
+	open Type
+
+	exception ReadError
+
+	fun fromUtf8 v =
+	    let val len = Word8Vector.length v
+		val index = ref 0
+		fun getc () =
+		    case getc' () of
+			SOME c => c
+		     |  NONE => raise ReadError
+		and getc' () =
+		    let val i = !index
+		    in if i = len then NONE
+		       else (index := i + 1;
+			     SOME (Byte.byteToChar (Word8Vector.sub (v, i))))
+		    end
+		and ungetc () = index := !index - 1
+		and sexp () : sexp =
+		    case getc () of
+			#"\"" => string (CharBuffer.new 100)
+		      | #"("  => lst ()
+		      | #"'" => Lst [Quote, sexp ()]
+		      | _ => (ungetc(); token ())
+		and string buf : sexp =
+		    case getc () of
+			#"\"" => Str (CharBuffer.toString buf)
+		      | #"\\" => (CharBuffer.append (buf, getc ()); string buf)
+		      | c => (CharBuffer.append (buf, c); string buf)
+		and lst () =
+		    let val x = sexp ()
+		    in case getc () of
+			   #")" => Lst [x]
+			 | #" " => let val Lst y = lst () in Lst (x :: y) end
+			 | _ => raise ReadError
+		    end
+		and token () =
+		    let val tok = token' (CharBuffer.new 50)
+			val c0 = String.sub (tok, 0)
+		    in if Char.isDigit c0 then (case Int.fromString tok of
+						    SOME i => Int i
+						  | NONE => raise ReadError)
+		       else
+			   Sym (tok)
+		    end
+		and token' buf : string =
+		    case getc' () of
+			NONE => CharBuffer.toString buf
+		      | SOME #"\\" => (CharBuffer.append (buf, getc ());
+				       token' buf)
+		      | SOME #" " => (ungetc (); CharBuffer.toString buf)
+		      | SOME #")" => (ungetc (); CharBuffer.toString buf)
+		      | SOME c => (CharBuffer.append (buf, c); token' buf)
+	    in
+		sexp ()
+	    end
+
+	fun toString sexp =
+	    case sexp of
+		(Str s) => "\"" ^ String.toCString s ^ "\""
+	      | (Lst []) => "nil"
+	      | (Lst xs) => "(" ^ String.concatWith " " (map toString xs) ^ ")"
+	      | Sym (name) => name
+	      | QSym (pkg, name) => pkg ^ ":" ^ name
+	      | Quote => "quote"
+	      | T => "t"
+	      | Nil => "nil"
+	      | Int i => Int.toString i
+
+	fun toUtf8 sexp = Util.stringToUtf8 (toString sexp)
+      end
+
+    structure Net = struct
+	local
+	    structure S = Socket
+	    structure I = INetSock
+	    structure W = Word8Vector
+
+	    fun createSocket (port) =
+		let val sock : S.passive I.stream_sock = I.TCP.socket ()
+		    val SOME localhost = NetHostDB.fromString "127.0.0.1"
+		in
+		    S.Ctl.setREUSEADDR (sock, true);
+		    S.bind (sock, I.toAddr (localhost, port));
+		    S.listen (sock, 2);
+		    sock
+		end
+
+	    fun addrToString sockAddr =
+		let val (ip, port) = I.fromAddr sockAddr
+		in NetHostDB.toString ip ^ ":" ^ Int.toString port
+		end
+
+	    exception ShortRead of W.vector
+	    exception InvalidHexString of string
+	in
+
+	fun acceptConnection port =
+	    let val sock = createSocket port
+		val addr = S.Ctl.getSockName sock
+		val _ = print ("Listening on: " ^ addrToString addr ^ "\n")
+		val (peer, addr) = S.accept sock
+	    in
+		S.close sock;
+		print ("Connection from: " ^ addrToString addr ^ "\n");
+		peer
+	    end
+
+	fun receivePacket socket =
+	    let val v = S.recvVec (socket, 6)
+		val _ = if W.length v = 6 then ()
+			else raise ShortRead v
+		val s = Util.utf8ToString v
+		val _ = print ("s = " ^ s ^ "\n")
+		val len =
+		    case StringCvt.scanString (Int.scan StringCvt.HEX) s of
+			SOME len => len
+		      | NONE => raise InvalidHexString s
+		val _ = print ("len = " ^ Int.toString len ^ "\n")
+		val payload = S.recvVec (socket, len)
+		val plen = W.length payload
+		val _ = print ("plen = " ^ Int.toString plen ^ "\n")
+		val _ = if plen = len then ()
+			else raise ShortRead payload
+	    in
+		payload
+	    end
+
+	fun nibbleToHex i:string = Int.fmt StringCvt.HEX i
+
+	fun loadNibble i pos =
+	    Word32.toInt (Word32.andb (Word32.>> (Word32.fromInt i,
+						  Word.fromInt (pos * 4)),
+				       0wxf))
+
+	fun hexDigit i pos = nibbleToHex (loadNibble i pos)
+
+	fun lenToHex i =
+	    concat [hexDigit i 5,
+		    hexDigit i 4,
+		    hexDigit i 3,
+		    hexDigit i 2,
+		    hexDigit i 1,
+		    hexDigit i 0]
+
+	fun sendPacket (payload:W.vector, socket) =
+	    let val len = W.length payload
+		val header = Util.stringToUtf8 (lenToHex len)
+		val packet = W.concat [header, payload]
+	    in  print ("len = " ^ Int.toString len ^ "\n"
+		       ^ "header = " ^ lenToHex len ^ "\n"
+		       ^ "paylad = " ^ Util.utf8ToString payload ^ "\n");
+		S.sendVec (socket, {buf = packet, i = 0, sz = NONE})
+	    end
+
+	end
+      end
+
+    structure Rpc = struct
+	open Sexp.Type
+
+	val funTable : (string, sexp list -> sexp) Map.map
+	    = Map.stringMap ()
+
+	fun define name f = Map.put (funTable, name, f)
+
+	exception UnknownFunction of string
+	fun call (name, args) =
+	    (print ("call: " ^ name ^ "\n");
+	     case Map.lookup (funTable, name) of
+		 SOME f => f args
+	       | NONE => raise UnknownFunction name)
+
+
+	local fun getpid () =
+	    Word32.toInt (Posix.Process.pidToWord (Posix.ProcEnv.getpid ()))
+	in
+	fun connectionInfo [] =
+	    Lst [Sym ":pid", Int (getpid ()),
+		 Sym ":lisp-implementation", Lst [Sym ":type", Str "MLWorks",
+						  Sym ":name", Str "mlworks",
+						  Sym ":version", Str "2.x"],
+		 Sym ":machine", Lst [Sym ":instance", Str "",
+				      Sym ":type", Str "",
+				      Sym ":version", Str ""],
+		 Sym ":features", Nil,
+		 Sym ":package", Lst [Sym ":name", Str "root",
+				      Sym ":prompt", Str "-"]]
+	end
+
+	fun nyi _ = Nil
+
+	local structure D = Shell.Dynamic
+	in
+	fun interactiveEval [Str string] =
+	    let val x = D.eval string
+	    in Str (concat [D.printValue x, " : ", D.printType (D.getType x)])
+	    end
+	end
+
+	val _ =
+	    (define "swank:connection-info" connectionInfo;
+	     define "swank:swank-require" nyi;
+	     define "swank:interactive-eval" interactiveEval;
+	     ())
+      end
+
+    structure EventLoop = struct
+	open Sexp.Type
+
+	fun execute (sexp, pkg) =
+	    (print ("sexp = " ^ (Sexp.toString sexp) ^ "\n");
+	     case sexp of
+		 Lst (Sym name :: args) => Rpc.call (name, args))
+
+	fun emacsRex (sexp, pkg, id as Int _, sock) =
+	    let val result = (Lst [Sym (":ok"), execute (sexp, pkg)]
+			      handle exn => (Lst [Sym ":abort",
+						  Str (exnName exn ^ ": "
+						       ^ exnMessage exn)]))
+		val reply = Lst [Sym ":return", result, id]
+	    in Net.sendPacket (Sexp.toUtf8 reply, sock)
+	    end
+
+	fun dispatch (Lst ((Sym key) :: args), sock) =
+	    case key of
+		":emacs-rex" => let val  [sexp, pkg, _, id] = args
+				in emacsRex (sexp, pkg, id, sock)
+				end
+
+	fun processRequests socket:unit =
+	    let val sexp = Sexp.fromUtf8 (Net.receivePacket socket)
+	    in print ("request: "
+		      ^ Util.utf8ToString (Sexp.toUtf8 sexp)
+		      ^ "\n");
+	       dispatch (sexp, socket);
+	       processRequests socket
+	    end
+
+      end
+
+    (* val _ = EventLoop.processRequests (Net.acceptConnection 4005) *)
+    val _ = ()
+  end
+
+(* (Swank.EventLoop.processRequests (Swank.Net.acceptConnection 4005)) *)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)

sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/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)