Author: hhubner
Date: 2006-11-30 11:32:54 -0500 (Thu, 30 Nov 2006)
New Revision: 2092
Added:
trunk/thirdparty/emacs/slime/doc/slime-small.eps
trunk/thirdparty/emacs/slime/doc/slime-small.pdf
trunk/thirdparty/emacs/slime/sbcl-pprint-patch.lisp
trunk/thirdparty/emacs/slime/swank-loader.x86f
trunk/thirdparty/emacs/slime/swank-version.el
Modified:
trunk/thirdparty/emacs/slime/ChangeLog
trunk/thirdparty/emacs/slime/PROBLEMS
trunk/thirdparty/emacs/slime/README
trunk/thirdparty/emacs/slime/doc/Makefile
trunk/thirdparty/emacs/slime/doc/slime.texi
trunk/thirdparty/emacs/slime/doc/texinfo-tabulate.awk
trunk/thirdparty/emacs/slime/hyperspec.el
trunk/thirdparty/emacs/slime/mkdist.sh
trunk/thirdparty/emacs/slime/nregex.lisp
trunk/thirdparty/emacs/slime/present.lisp
trunk/thirdparty/emacs/slime/slime.el
trunk/thirdparty/emacs/slime/swank-abcl.lisp
trunk/thirdparty/emacs/slime/swank-allegro.lisp
trunk/thirdparty/emacs/slime/swank-backend.lisp
trunk/thirdparty/emacs/slime/swank-clisp.lisp
trunk/thirdparty/emacs/slime/swank-cmucl.lisp
trunk/thirdparty/emacs/slime/swank-corman.lisp
trunk/thirdparty/emacs/slime/swank-ecl.lisp
trunk/thirdparty/emacs/slime/swank-gray.lisp
trunk/thirdparty/emacs/slime/swank-lispworks.lisp
trunk/thirdparty/emacs/slime/swank-loader.lisp
trunk/thirdparty/emacs/slime/swank-openmcl.lisp
trunk/thirdparty/emacs/slime/swank-sbcl.lisp
trunk/thirdparty/emacs/slime/swank-scl.lisp
trunk/thirdparty/emacs/slime/swank-source-file-cache.lisp
trunk/thirdparty/emacs/slime/swank-source-path-parser.lisp
trunk/thirdparty/emacs/slime/swank.asd
trunk/thirdparty/emacs/slime/swank.lisp
trunk/thirdparty/emacs/slime/test-all.sh
trunk/thirdparty/emacs/slime/test.sh
Log:
Update slime
Modified: trunk/thirdparty/emacs/slime/ChangeLog
===================================================================
--- trunk/thirdparty/emacs/slime/ChangeLog 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/ChangeLog 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,5 +1,3092 @@
+2006-11-26 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-source-file-cache.lisp (buffer-first-change): Check
+ whether a file exists before trying load it into the source cache.
+
+2006-11-26 Juho Snellman <jsnell(a)iki.fi>
+
+ Restore the way M-n and M-p used to work in the REPL. (cherry-picked
+ from a patch with other changes, sent by Attila Lendvai).
+
+ * slime.el (slime-repl-previous-input-starting-with-current-input)
+ (slime-repl-next-input-starting-with-current-input): New functions,
+ work like the old slime-repl-previous-input / next-input.
+ (slime-repl-matching-input-regexp): Restore old version.
+ (slime-repl-mode-map): Bind s-r-p-i-s-w-c-i and s-r-n-i-s-w-c-i
+ to M-p and M-n respectively. slime-repl-previous-input and
+ slime-repl-next-input are still accessible with C-up / C-down.
+
+2006-11-25 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-repl-read-break): Use a :emacs-interrupt message
+ instead of a RPC to swank:simple-break. Suggested by Taylor R
+ Campbell.
+
+2006-11-24 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-search-buffer-package): Prettify the package
+ name if it is written as string or keyword.
+
+2006-11-23 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-in-expression-p): Use `read' and `eq' to test
+ the first element of the list. Previuosly, the pattern (foo)
+ wrongly matched (foobar) because we used (looking-at <symbol>).
+
+ * swank-cmucl.lisp (setf-definitions): Also include defs which
+ were created with (defun (setf NAME) ...). Previously we only
+ found definitions created with defsetf or define-setf-expander.
+
+2006-11-22 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-edit-definition): Don't hide error messages.
+
+2006-11-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (*coding-system*): "Coding systems" are now strings
+ instead of keywords.
+
+2006-11-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-compile-file): Let the Lisp side choose the
+ coding system.
+ (slime-coding): Deleted.
+
+ * swank.lisp (compile-file-for-emacs): Use guess-external-format.
+ (swank:create-server): no more accepts an :external-format 'enc ,
+ use :coding-system "enc" instead.
+
+ * swank-backend.lisp (find-external-format)
+ (guess-external-format): New.
+ (swank-compile-file): The external-format argument is now a
+ backend specific value returned by find-external-format.
+
+ * swank-cmucl.lisp, swank-sbcl.lisp, swank-clisp,
+ swank-lispworks.lisp, swank-allegro.lisp, swank-corman.lisp,
+ swank-ecl.lisp, swank-scl.lisp, swank-abcl.lisp, swank-openmcl:
+ Update implementations accordingly.
+
+ * swank-source-file-cache.lisp (read-file): Use guess-external-format.
+
+ * swank.lisp (*swank-wire-protocol-version*): Is now initialized
+ by the loader.
+ (wire-protocol-version): Removed, because it contained a reference
+ to swank-loader::*source-directory*.
+
+ * slime.el (slime-set-connection-info): On protocol version
+ mismatch, ask the user how to proceed.
+ (slime-protocol-version): New variable. Initialize it at compile
+ time to detect stale elc files.
+
+ * swank-loader.lisp (load-swank): Set the protocol version.
+
+2006-11-12 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-make-tramp-file-name): Added (require 'tramp)
+ since tramp-make-tramp-file-name is not an autoloaded function.
+
+2006-11-07 Edi Weitz <edi(a)agharta.de>
+
+ * slime.el (slime-fuzzy-completion-time-limit-in-msec): Escaped
+ left parenthesis in doc string.
+
+2006-11-05 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-complete-keywords-contextually): Unused
+ variable, removed.
+
+2006-11-05 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (sldb-sexp-highlight-mode): Remove bloat.
+
+2006-11-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Support nested presentations in REPL results, when present.lisp is
+ loaded.
+
+ * swank.lisp (make-presentations-result): New, factored out from
+ listener-eval.
+ (listener-eval): Use it here.
+
+ * present.lisp (make-presentations-result): Override it here.
+
+2006-11-03 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (all-slots-for-inspector): Added declare ignore for
+ unused argument inspector (openmcl warns about this). Reindented.
+
+2006-11-01 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el (sldb-sexp-highlight-mode): New custom.
+ (slime-handle-repl-shortcut): Trigger slime-lookup-shortcut when
+ the point is anywhere before slime-repl-input-start-mark. IOW,
+ you can press "," anywhere before the prompt.
+ (slime-edit-definition): Handle the case when there are only such
+ entries returned from swank that have errors.
+ (slime-read-from-minibuffer): Allow overriding of the keymap.
+ (slime-repl-previous-matching-input): Similar behaviour like
+ isearch-forward.
+ (slime-repl-next-matching-input): Ditto. In more details: You can
+ freely navigate with slime-repl-previous/next-input with M-p and
+ M-n at any time among the history entries. When M-r is pressed,
+ which invokes slime-repl-previous-matching-input, the the
+ minibuffer is activated to read the regexp to search for and the
+ contents will default to the current repl input. Pressing M-r
+ again will start searching with the last pattern used no matter
+ what the content of the minibuffer is. Subsequent invocations of
+ M-r get the next match, and of course the same applies for M-s,
+ which is slime-repl-previous-matching-input.
+
+ * swank.lisp (fuzzy-completion-set): Fix on clisp.
+ (convert-fuzzy-completion-result): Fix symbol fbound and other
+ annotations.
+ (slot-value-using-class-for-inspector): New.
+ (slot-boundp-using-class-for-inspector): New.
+ (inspect-for-emacs): Use the special slot access methods so that
+ it's possible to customize the inspecting of complex
+ slots (e.g. computed-class at
+ http://common-lisp.net/project/computed-class/).
+ (all-slots-for-inspector): Converted to generic method.
+
+2006-11-01 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (*swank-wire-protocol-version*): Use a defvar to
+ declare the existence of tihs variable to the lisp (Reported by:
+ Jonathon McKitrick <jcm(a)FreeBSD-uk.eu.org>).
+
+2006-10-30 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (*dont-close*): New variable.
+ (defpackage :swank): Export *dont-close*.
+ (start-server, create-server): Use *dont-close* as the default
+ value of the :dont-close parameter.
+ (connection-info): Send the wire-protocol-version (supplied by the
+ swank-version.el file) to slime when connecting.
+ (wire-protocol-version): New function.
+
+ * slime.el (slime-global-variable-name-regexp): New variable.
+ (slime-global-variable-name-p): Use
+ slime-global-variable-name-regexp.
+ ("swank-version"): Load swank-version.el to get the wire protocol
+ version.
+ (slime-set-connection-info): Check the wire protocol version.
+
+2006-10-30 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-global-variable-name-p): Oops... need to handle
+ very long strings.
+
+2006-10-29 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el (slime-global-variable-name-p): Use defun* instead of
+ defun.
+
+2006-10-29 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-global-variable-name-p): Simplified.
+
+2006-10-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Add completion for character names.
+
+ * slime.el (slime-completions-for-character): New.
+ (slime-contextual-completions): Use it here.
+
+ * swank-backend.lisp (character-completion-set): New interface.
+
+ * swank-allegro.lisp (character-completion-set): Implement it.
+
+ * swank.lisp (completions-for-character): New slimefun.
+ (compound-prefix-match/ci/underscores)
+ (longest-completion/underscores, tokenize-completion/underscores)
+ (untokenize-completion/underscores): New functions.
+
+2006-10-28 Ivan Toshkov <ivan(a)toshkov.org>
+
+ * hyperspec.el: Missing Hyperspec links for ~| and ~~
+
+2006-10-27 Ivan Toshkov <ivan(a)toshkov.org>
+
+ * hyperspec.el: Missing Hyperspec links for ~% and ~&
+
+2006-10-27 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * swank-sbcl.lisp (make-weak-key-hash-table): Restore support
+ for older SBCLs without weak hash-tables.
+ (make-weak-value-hash-table): Ditto.
+
+2006-10-26 Utz-Uwe Haus <haus+slime(a)mail.math.uni-magdeburg.de>
+
+ * swank-allegro.lisp (sldb-break-at-start): Implement.
+
+2006-10-26 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el (slime-setup-command-hooks): Use make-local-hook.
+ (slime-repl-mode): Ditto.
+ (slime-fuzzy-choices-buffer): Ditto.
+ (sldb-mode): Ditto.
+ (slime-fuzzy-completion-limit): New variable.
+ (slime-fuzzy-completion-time-limit-in-msec): New variable.
+ (slime-fuzzy-next): Fix when at the end of the buffer.
+ (completion-output-symbol-converter): New to handle escaped
+ symbols for those who need to mess around with symbols like
+ layered-function-definers::|CONTEXTL::SLOT-VALUE-USING-LAYER|.
+ When a symbol is escaped then completion is case sensitive.
+ (completion-output-package-converter): New.
+ (mimic-key-bindings): New to easily define bindings by first
+ trying to look up bindings for an operation and only use the
+ provided default bindings if nothing was found in the source
+ keymap. Use it to set up fuzzy bindings. (Hint: if you have keys
+ like previous-line customized, then only load slime after they
+ have been set, and the fuzzy mode will mimic them.)
+ (slime-temp-buffer-quit): Always close the opened window, updated
+ docstring. Also made the fuzzy maps smarter, they now try to look
+ up keys with 'where-is-internal and map the functions on them.
+
+ * swank-sbcl.lisp
+ (make-weak-value-hash-table): New for sbcl.
+ (make-weak-key-hash-table): New for sbcl.
+
+ * swank.lisp (fuzzy-completions and friends): Added :limit and
+ :time-limit-in-msec keyword params. Used vectors instead of lists
+ that nearly doubled its speed (at least on sbcl). Also added some
+ declare optimize and type annotations.
+ (do-symbols*): New, uses a hash-table to visit only non-seen
+ symbols. Replaced various uses of do-symbols where it was
+ appropiate.
+
+2006-10-26 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-global-variable-name-p): Use a custom 'parser'
+ instead of string-match to avoid regexp overflow errors on very
+ long strings.
+
+2006-10-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-lispworks.lisp (initialize-multiprocessing): Don't init
+ MP if it is already running.
+
+ * test.sh: Run Emacs in Screen.
+
+2006-10-20 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-backend.lisp, swank-cmucl.lisp:
+ (startup-idle-and-top-level-loops): Deleted. Merged into
+ initialize-multiprocessing.
+
+2006-10-20 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el (slime-fuzzy-choices-buffer): Added kill-buffer-hook to
+ the completion buffer to slime-fuzzy-abort, so we get out from the
+ completion mode and key maps when the completion buffer is closed.
+
+2006-10-20 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-target-buffer-fuzzy-completions-map): Fix a bug
+ I introduced when applying levente's patch.
+
+2006-10-20 Martin Simmons <martin(a)lispworks.com>
+
+ * swank-backend.lisp (initialize-multiprocessing): New API to
+ support lisps where initialize-multiprocessing may not return (lispworks).
+
+ * swank.lisp (start-server): initialize-multiprocessing's API has changed.
+
+ * swank-lispworks.lisp (initialize-multiprocessing): Update for new API.
+
+ * swank-cmucl.lisp (initialize-multiprocessing): Update for new API.
+
+ * swank-allegro.lisp (initialize-multiprocessing): Update for new api.
+
+2006-10-20 Levente M�sz�ros <levente.meszaros(a)gmail.com>
+
+ Added "in-place" fuzzy completion GUI. See
+ slime-fuzzy-completions-map and
+ slime-target-buffer-fuzzy-completions-map for details.
+
+ * slime.el (slime-fuzzy-completion-in-place): New variable.
+ (slime-target-buffer-fuzzy-completions-mode): New keymap for
+ in-place fuzzy completions.
+ (slime-fuzzy-target-buffer-completions-mode): New minor mode for
+ in-place fuzzy completions.
+ (slime-fuzzy-current-completion-overlay): New overlay for
+ highlighting currently selected completion.
+ (slime-fuzzy-completions-map): Added new fuzzy completon keys
+ (slime-fuzzy-indent-and-complete-symbol): New function.
+ (slime-fuzzy-complete-symbol): Use new in-place fuzzy completion.
+ (slime-fuzzy-choices-buffer): Support in-place completion editing.
+ (slime-fuzzy-fill-completions-buffer): Highlight completions,
+ don't automatically jump to completion buffer.
+ (slime-fuzzy-enable-target-buffer-completions-mode,
+ slime-fuzzy-disable-target-buffer-completions-mode): New modes for
+ moving in/out of in-place fuzzy completion mode
+ (slime-fuzzy-next, slime-fuzzy-prev): Don't assume point is in the
+ completion buffer.
+ (slime-fuzzy-dehighlight-current-completion,
+ slime-fuzzy-highlight-current-completion): Manage completion
+ selection highlighting.
+ (slime-fuzzy-select-or-update-completions): New function.
+ (slime-fuzzy-process-event-in-completions-buffer): New function.
+ (slime-fuzzy-select-and-process-event-in-target-buffer): New function.
+ (slime-fuzzy-done): Changed to deal with in-place completion.
+
+2006-10-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-backend.lisp (ignored-xref-function-names): Deleted.
+
+ * swank.lisp (guess-package-from-string): Remove special case for
+ "#.". parse-package will handle that just fine.
+ (find-definitions-for-emacs): Don't filter errors out.
+ (sanitize-xrefs): Moved to swank-sbcl. The backend is supposed to
+ return sane values.
+
+ * swank-sbcl.lisp: See above.
+
+ * slime.el (slime-find-buffer-package): Simplify.
+
+2006-10-17 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-accept-process-output): The timeout arg can be
+ nil. Handle that case.
+
+2006-10-17 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el (slime-find-buffer-package): Handle #. forms.
+
+ * swank.lisp (guess-package-from-string): Handle #. forms.
+ (inspect-for-emacs standard-class): Handle non-string
+ :documentation slot contents.
+
+ * swank-sbcl.lisp (inspect-for-emacs weak-pointer ...): Added
+ method.
+
+2006-10-16 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (sldb-activate): Get debug-info from the correct
+ thread. Fixes bug reported by Dan Weinreb <dlw(a)itasoftware.com>.
+ (unwind-to-previous-sldb-level): New test.
+ (slime-init-command): Send a single form.
+ (slime-insert-presentation): Honor slime-repl-enable-presentations.
+ Presentations kill SLDB and the inspector in Emacs 20 (besides
+ being troublesome GC-wise).
+
+ * swank.lisp: Clean up global IO redirection.
+ (setup-stream-indirection): Turn macro into a
+ function and delay initialization after user init files are
+ loaded, so that we do nothing if *globally-redirect-io* is nil.
+ (*after-init-hook*, run-after-init-hook)
+ (init-global-stream-redirection): New.
+
+ (parse-symbol-or-lose): Lose loudly and early (instead of failing
+ silently).
+
+ * swank-loader.lisp: Abort on compile-time or load-time errors.
+ Don't try to load the source-file if COMPILE-FILE's 3rd return
+ value is true (it's true even for warnings).
+ (handle-loadtime-error): New function.
+
+ Run the after-init-hook.
+
+ * swank-cmucl.lisp (inspect-for-emacs): Don't break for
+ simple-strings.
+
+2006-10-11 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-presentation-syntax-table): New.
+ (slime-add-presentation-properties): Install it in a syntax-table
+ text property, so that #<...> is balanced in a presentation.
+ (slime-remove-presentation-properties): Remove the text property.
+ (slime-repl-mode): Respect the syntax text properties of
+ presentations in REPL buffers.
+
+2006-10-09 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (completions-for-keyword): Look up the operator names
+ in the right package. Return nil (rather than signalling an
+ error) when no valid operator name is present.
+
+2006-10-08 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank-loader.lisp (lisp-version-string) [allegro]: Distinguish
+ between 32-bit and 64-bit version on the SPARC architecture.
+
+2006-10-03 Marco Baringer <mb(a)bese.it>
+
+ Change license statement to say that all files without an explicit
+ copyright notice are public domain. This change will allow SLIME
+ to moved out of debian's nonfree tree.
+
+ * README: Update license statement.
+
+2006-10-02 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-highlight-compiler-notes): New variable.
+ (slime-compilation-finished): Only highlight notes when
+ slime-highlight-compiler-notes is non-NIL.
+
+2006-09-28 Marco Baringer <mb(a)bese.it>
+
+ * swank-loader.lisp (compile-files-if-needed-serially): Don't
+ ignore compile-time errors but drop into a debugger (it's not a
+ slime debugger but it's certainly better than ignoring the error).
+
+2006-09-27 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (*globally-redirect-io*): Change default value to T.
+
+2006-09-25 Juho Snellman <jsnell(a)iki.fi>
+
+ Fix Slime on SBCL 0.9.17.
+
+ * swank-backend.lisp (ignored-xref-function-names): New interface
+
+ * swank.lisp (sanitize-xrefs): Use ignored-xref-function-names
+ instead of having a #+sbcl special case.
+
+ * swank-sbcl.lisp (ignored-xref-function-names): Implement.
+ Filter out SB-C::STEP-VALUES, not just SB-C::STEP-FORM, as done by
+ the old sanitize-xrefs. Don't implement the interface at all if
+ SBCL is sufficiently new (those symbols don't exist any more, and
+ there's nothing in their place to be ignored).
+
+2006-09-21 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (find-definitions-for-emacs): Don't return locations
+ whose CAR is :error.
+ (xref): Process whatever is returned by the various xref functions
+ with the new sanitize-xrefs functions.
+ (sanitize-xrefs): Clean up the list of xrefs to remove duplicates.
+ Patch by Dan Weinreb <dlw(a)itasoftware.com>
+
+ * slime.el (slime-goto-first-note-after-compilation): New
+ variable. This controls the behaviour of (next|prev)-note
+ immediatly after a slime-compile-and-load-file.
+ (slime-compilation-just-finished): New variable.
+ (slime-compilation-finished): Update slime-compilation-finished.
+ (slime-next-note, slime-previous-note): Respect
+ slime-compilation-just-finished.
+ (slime-autodoc-use-multiline-p): Specify the type.
+ (slime-repl-grab-old-input): Typo in docstring.
+ (slime-cheat-sheet): Deal with multiple-bindings
+ (slime-cheat-sheet-table): Update as per #lisp's suggestions.
+
+2006-09-20 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-cheat-sheet): New function.
+ (slime-cheat-sheet-table): New variable which specifies what the
+ cheat sheet should list.
+ (slime-read-package-name): Set require to T in the call to
+ completing read, it doesn't make any sense to switch to an
+ inexistent package.
+
+ * doc/slime.texi: Added "Tips and Tricks" chapter (need a better
+ name for this).
+
+ * swank-sbcl.lisp (fallback-source-location): Use abort-request
+ instead of error.
+ (locate-compiler-note): Say, in the error message, what data
+ caused the error.
+
+2006-09-20 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (call-with-debugger-hook): use INVOKE-STEPPER
+ instead of calling the stepper hook manually
+
+2006-09-19 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (call-with-debugger-hook): make the stepper
+ also work with a threaded SBCL, by binding a handler for
+ sb-ext:stepper-condition instead of relying on the one that SBCL
+ establishes on the toplevel
+
+2006-09-19 Juho Snellman <jsnell(a)iki.fi>
+
+ Extend the stepper protocol to work nicely with the SBCL stepper.
+
+ If sldb is invoked on a condition that's sldb-stepper-condition-p,
+ the sldb functions sldb-step, sldb-next and sldb-out will invoke
+ the matching backend functions for stepping into the stepped form,
+ to the next form, or out of the current function. Otherwise the
+ functions will behave like sldb-step used to (call active-stepping and
+ select the continue restart).
+
+ * swank-backend.lisp (sldb-stepper-condition-p, sldb-step-into,
+ sldb-step-next, sldb-step-out): New interface functions
+
+ * swank-sbcl.lisp (activate-stepper, condition-extras,
+ sldb-stepper-condition-p, sldb-step-into, sldb-step-next,
+ sldb-step-out): Implemented (conditional on CVS SBCL)
+ (call-with-debugger-hook): bind sb-ext:*stepper-hook* to
+ a function that binds *stack-top-hint* and invokes the debugger
+ (conditional on CVS SBCL)
+
+ * swank.lisp (define-stepper-function): new macro for defining
+ stepper-related functions, since they all follow the same form
+ (sldb-step): redefine with define-stepper-function
+ (sldb-next, sldb-out): new functions
+ (*sldb-stepping-p*): typo in docstring
+
+ * slime.el (sldb-next, sldb-out): New commands
+ (sldb-mode-map): bind sldb-next to "x" and sldb-out to "o"
+
+2006-09-18 Dan Weinreb <dlw(a)itasoftware.com>
+
+ For those cases where SLIME can't complete a user request (like
+ loading an asdf system without asdf or describing an inexistent
+ symbol) instead of signaling an error SWANK should politely inform
+ the user and return normally.
+
+ * swank.lisp (eval-for-emacs): Handle request-abort conditions.
+ (decode-keyword-arg, get-repl-result, parse-symbol-or-lose): Use
+ abort-request instead of error.
+
+ * swank-backend.lisp (request-abort): New condition.
+ (abort-request): Convenience function for signaling request-abort
+ conditions.
+ (operate-on-system): Use abort-request instead of error
+ (:swank-backend): Export the symbols abort-request and
+ request-abort.
+
+ * slime.el (slime-rex): Update docstring.
+ (slime-eval, slime-eval-async): Added new REASON parameter sent
+ along with :abort message.
+
+2006-09-14 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-scl (arglist, function-arglist, spawn): update for the SCL.
+
+2006-09-13 Brandon Bergren <bdragon(a)mailsnare.net>
+
+ * slime.el (slime-filename-translations): Fix docstring
+
+2006-09-13 Bob Halley <halley(a)play-bow.us>
+
+ * swank.lisp (format-iso8601-time): Properly handle non integer
+ time zones.
+
+2006-09-13 Taylor R Campbell <campbell(a)mumble.net>
+
+ * slime.el (slime-init-output-buffer): Initial directory and
+ package stacks should be empty.
+ (slime-repl-push-package): Push the current package, as opposed to
+ the new package, and set the new package to whatever the user
+ specified.
+ (slime-repl-pop-package): Set the current package to the top of
+ the package stack, unless it's empty.
+
+2006-09-13 Daniel Koning <dkoning(a)seas.smu.edu>
+
+ * slime.el (slime-repl-disconnect): New repl shortcut.
+
+2006-09-13 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-open-inspector): Added a slime-part-number
+ property to the topline so that you can slime-inspector-copy-down
+ the object being inspected. There are some cases where we have an
+ object in the inspector and we'd like to dump it to the repl but
+ we can't get at it through other means (like in back-traces).
+ (slime-insert-xrefs): Specify which file the item is in (when that
+ information is available).
+
+ * swank.lisp (format-arglist-for-echo-area): Instead of using
+ let+first+rest to destructure a form use destructuring-bind.
+ (lookup-presented-object): Added (declare (special
+ *inspectee-parts*)) to silence openmcl's compiler.
+ (inspect-object): Generate, and send to emacs, an ID for the
+ object being inspected.
+
+2006-09-01 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * slime.el (slime-repl-matching-input-regexp): Use the portion
+ between slime-repl-input-mark and point for history search, not
+ the entire input. Patch by Ivan Shvedunov.
+
+ * swank-sbcl.lisp: Declaim SB-C:INSERT-STEP-CONDITIONS 0 for to
+ hide Swank while stepping and avoid endless mutex-acquisition
+ loops.
+
+2006-08-27 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (input-available-p, process-available-input): Use
+ READ-CHAR-NO-HANG instead of LISTEN because LISTEN suddenly
+ returns false in SBCL 0.9.?? even if we are called from a
+ fd-handler and the OPEN-STREAM-P returns true.
+
+2006-08-26 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-repl-return-behaviour): Fix the defcustom type,
+ so Emacs 21.3 does not signal an error when creating a
+ customization buffer containing this variable.
+
+2006-08-25 Kai Kaminski <kai.kaminski(a)gmx.de>
+
+ * swank.lisp (lookup-presented-object): Fix for OpenMCL 1.0
+ [ppc32], which requires that the :NO-ERROR clause is last in
+ HANDLER-CASE.
+
+2006-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-ensure-presentation-overlay): Provide a
+ help-echo for presentations, showing the mouse bindings.
+ (slime-presentation-around-click): New function.
+ (slime-copy-or-inspect-presentation-at-mouse)
+ (slime-inspect-presentation-at-mouse)
+ (slime-copy-presentation-at-mouse)
+ (slime-describe-presentation-at-mouse)
+ (slime-pretty-print-presentation-at-mouse): New commands.
+ (slime-copy-presentation-at-point): Removed (misnomer).
+ (slime-presentation-map): Bind mouse-2 to
+ slime-copy-or-inspect-presentation-at-mouse, so the right thing is
+ done in REPL buffers and in Inspector and Debugger buffers.
+ (slime-menu-choices-for-presentation): Use the new commands here
+ instead of inline lambdas.
+ (sldb-inspect-in-frame): Use slime-read-object here, so if point
+ is in a presentation in the debugger buffer, inspect it
+ immediately just like slime-inspect does.
+ (slime-inspect-presented-object): Removed.
+ (slime-inspect): Don't expect that "swank:init-inspector" is
+ already part of the form. Accept an optional arg "no-reset".
+ (slime-read-object): Don't add "swank:init-inspector" to the read
+ form; slime-inspect now adds it.
+
+2006-08-21 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Make the values of local variables in debugger frames and values
+ of parts in the inspector accessible as presentations. In
+ particular, this allows to copy #<unreadable> values to the REPL
+ for further investigation. It also provides a context menu for
+ the values, offering to inspect, pretty-print, and describe them.
+
+ Note that the presentations are only valid as long as the
+ corresponding Inspector or Debugger buffer is open.
+
+ * swank.lisp (lookup-presented-object): Handle presentation ids
+ (:frame-var frame index), (:inspected-part part-index).
+ (init-inspector): New optional argument, reset.
+
+ * slime.el (slime-inspector-insert-ispec): Mark up all values of
+ inspected parts as presentations.
+ (sldb-insert-locals): Mark up the values of local variables as
+ presentations.
+ (slime-remove-presentation-properties): Fix for read-only buffers.
+ (slime-copy-presentation-at-point): Make it work when the current
+ buffer is not the REPL buffer.
+ (slime-menu-choices-for-presentation): Describe into a separate
+ buffer, not the REPL. New menu item, pretty-print.
+ (slime-presentation-expression): Handle presentation ids that are
+ not numbers.
+ (slime-inspect-presented-object): Don't reset the inspector if
+ already in the inspector buffer.
+
+2006-08-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (*nil-surrogate*): New.
+ (save-presented-object, lookup-presented-object): Distinguish
+ between a saved NIL and a garbage-collected object that was
+ replaced by NIL in the weak hash table.
+ (compute-enriched-decoded-arglist with-open-file): Add an IGNORE
+ declaration.
+
+2006-08-19 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-parse-extended-operator-name/apply): New.
+ (slime-extended-operator-name-parser-alist): Add it to the alist.
+
+ * swank.lisp (compute-enriched-decoded-arglist): Add method for
+ handling APPLY.
+
+2006-08-14 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-accept-process-output): Use brute-force to
+ detect whether accept-process-output can be called with a float as
+ timeout arg.
+
+ * swank-openmcl.lisp: Fix some breakage caused by the new
+ defimplementation.
+
+2006-08-11 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (close-connection, swank-error): Include backtraces
+ in our own errors.
+ (simple-serve-requests): Don't try to enter the
+ debugger if the connection is closed.
+
+ * slime.el (disconnect): Test disconnecting.
+
+ * swank-cmucl.lisp (startup-idle-and-top-level-loops): Initialize
+ MP only once.
+
+2006-08-10 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-allegro.lisp (fspec-definition-locations): Improve
+ handling of (:internal ... n) like fspecs.
+
+ * slime.el (slime-restart-inferior-lisp-aux): Remove the
+ interactive spec.
+
+ * swank-backend.lisp (definterface): Drop that incredibly
+ unportable CLOS stuff. Use plists and plain functions instead.
+ Update backends accordingly.
+
+2006-08-09 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-find-filename-translators): CL:MACHINE-INSTANCE
+ can return nil. Silently accept that case for now.
+
+ * swank.lisp (test-print-arglist): Print a message instead of
+ signalling an error. This should avoid startup problems, in
+ particular with CormanLisp.
+ (setup-stream-indirection): Disable it for now. We should fix it,
+ if there is a need for this functionality or just remove it.
+
+ * swank-backend.lisp (definterface): Bring the old implementation
+ based on NO-APPLICABLE-METHOD back. It avoids lots of redefintion
+ warnings (but it creates more "noise" in backtraces).
+
+ * swank-*.lisp (inspect-for-emacs): Don't use defimplementation
+ for real generics.
+
+2006-07-28 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-thread-quit): Call swank:quit-thread-browser.
+ Reported by Taylor R Campbell.
+
+2006-07-28 Willem Broekema <metawilm(a)gmail.com>
+
+ * swank-allegro.lisp: Profiling functions on Allegro (except for
+ profile-package).
+
+2006-07-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Add support for destructuring macro arglists in arglist display,
+ form completion, and keyword completion; in particular for
+ with-open-file.
+
+ * swank.lisp (find-valid-operator-name): New, factored out from
+ arglist-for-echo-area.
+ (arglist-for-echo-area): Use it here.
+ (print-arglist): New, factored out from decoded-arglist-to-string.
+ Handle recursive arglist structures that arise in destructuring
+ macro arglists.
+ (decode-required-arg, encode-required-arg): New, handle
+ destructuring patterns.
+ (decode-keyword-arg, encode-keyword-arg, decode-optional-arg)
+ (encode-optional-arg, decode-arglist, encode-arglist): Use them
+ here to handle destructuring patterns.
+ (print-decoded-arglist-as-template): Change interface, handle
+ destructuring patterns.
+ (decoded-arglist-to-template-string): Use it here.
+ (enrich-decoded-arglist-with-keywords): New, factored out from
+ enrich-decoded-arglist-with-extra-keywords.
+ (enrich-decoded-arglist-with-extra-keywords): Use it here.
+ (compute-enriched-decoded-arglist): New generic function, factored
+ out from arglist-for-insertion, form-completion. Add specialized
+ method for with-open-file.
+ (arglist-for-insertion, form-completion): Use it here.
+ (arglist-ref): New.
+ (completions-for-keyword): Change interface, handle destructuring
+ macro arglists.
+
+ * slime.el (slime-enclosing-operator-names): For nesting levels
+ without operator, record nil.
+ (slime-completions-for-keyword): New argument arg-indices.
+ (slime-contextual-completions): Pass all enclosing operators and
+ arg-indices to slime-completions-for-keyword.
+
+2006-07-16 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-edit-definition): Invoke the
+ slime-edit-definition-fall-back-function also in the case where
+ find-definitions-for-emacs returns an error message.
+ (slime-edit-definition-fallback-function): Fix typo (find-tag
+ rather than find-tags).
+
+2006-07-15 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (preferred-communication-style): Remove use of
+ linux_no_threads_p alien variable (the value has been hardcoded to
+ false for about a year), so that we can also remove it from from SBCL
+ in the future.
+ (*definition-types*): defcondition -> define-condition,
+ to make slime-show-definitions display condition FOO as
+ (DEFINE-CONDITION FOO) instead of (SWANK-BACKEND::DEFCONDITION FOO).
+
+2006-07-15 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-shared-lisp-mode-hook): New function, factored
+ out from slime-lisp-mode-hook.
+ (slime-lisp-mode-hook): Use it here.
+ (slime-scheme-mode-hook): New function, use
+ slime-shared-lisp-mode-hook.
+ (slime-setup): If scheme-mode is one of the slime-lisp-modes,
+ install our hook.
+
+2006-07-13 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (keywords-of-operator): New support function for
+ writing user-defined `extra-keywords' methods.
+
+2006-07-11 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-allegro.lisp (make-weak-key-hash-table): Use ACL's weak
+ hashtables.
+
+ * swank.asd: Set *source-directory* to the asdf component dir.
+
+2006-07-01 Lu�s Oliveira <loliveira(a)common-lisp.net>
+
+ * swank-sbcl.lisp (locate-compiler-note): Change first branch to
+ handle the changes introduced by the previous patch to
+ swank-compile-string.
+
+2006-06-26 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-sbcl.lisp (find-definitions): Remove backward
+ compatibility code.
+
+2006-06-26 Lu�s Oliveira <loliveira(a)common-lisp.net>
+
+ * swank-sbcl.lisp (tmpnam, temp-file-name): New functions.
+ (swank-compile-string): Create temporary file with the string and
+ compile-file it instead of compiling an anonymous lambda, as
+ before, in order to better handle eval-when forms.
+
+2006-06-25 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-source-path-parser.lisp (suppress-sharp-dot): Return a
+ unique symbol to avoid multiple entries for nil at toplevel in the
+ source-map.
+
+ * slime.el (test compile-defun): Add a test for #. reader macro at
+ toplevel.
+ (slime-run-one-test): New command.
+ (sldb-activate): Recreate the sldb buffer if it doesn't
+ exist. (Can happen if someone kills the buffer manually.)
+ (slime-wait-condition): Add a dummy to slime-stack-eval-tags while
+ waiting so that the SLDB enters a recursive edit.
+
+2006-06-18 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-echo-arglist): Simplify, just use slime-autodoc.
+
+ * swank.lisp (arglist): Distinguish between provided actual args
+ and required formal args using the new slot provided-args.
+ (form-completion): Likewise.
+ (decoded-arglist-to-string): Use it here to display the argument
+ list (make-instance 'CLASS-NAME ...) rather
+ than (make-instance (quote CLASS-NAME) ...).
+
+ * swank.lisp (extra-keywords change-class): Don't drop the first
+ argument.
+
+ * slime.el (slime-parse-extended-operator-name): Don't move
+ point; fixes infinite loop.
+
+2006-06-17 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-parse-extended-operator-name/cerror): Handle
+ cerror and change-class with :make-instance.
+ (slime-extended-operator-name-parser-alist): Handle change-class.
+ (slime-parse-extended-operator-name)
+ (slime-enclosing-operator-names): Fix the case when point is
+ within the operator.
+
+ * swank.lisp (operator-designator-to-form): Handle cerror and
+ change-class with :make-instance.
+
+2006-06-16 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (operator-designator-to-form): Handle :cerror.
+ (extra-keywords cerror): Make it work.
+
+ * slime.el (slime-parse-extended-operator-name)
+ (slime-parse-extended-operator-name/make-instance)
+ (slime-parse-extended-operator-name/defmethod): New functions,
+ factored out from slime-enclosing-operator-names.
+ (slime-parse-extended-operator-name/cerror): New function.
+ (slime-extended-operator-name-parser-alist): New variable.
+ (slime-enclosing-operator-names): Use them here.
+
+2006-06-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-goto-definition): If all definitions of a name
+ have the same location, go there directly rather than presenting
+ an xref buffer.
+
+2006-06-11 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-scl (ext:stream-write-chars): update for SCL 1.3.
+
+2006-06-09 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-abcl: Update to cvs version of abcl and warnings errors
+ when compiling in a buffer will now be properly caught by slime vs
+ current behavior of always saying 0 errors 0 warnings and printing
+ them in the repl instead
+
+2006-05-31 Nathan Bird <nathan(a)acceleration.net>
+
+ * swank.lisp (*sldb-quit-restart*): New variable.
+ (throw-to-toplevel): Use the restart named by *sldb-quit-restart*
+ as opposed to hard coding abort-request.
+
+2006-05-30 Tobias Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-get-temp-buffer-create): New keyword REUSEP
+ which indicates whether an already-existing buffer named like the
+ buffer to be created should be reused, i.e. not killed, then
+ freshly created. Update docstring accordingly.
+ (slime-with-output-to-temp-buffer): Make &optional arg MODE an
+ &key keyword arg. Add REUSEP keyword.
+ (slime-macroexpansion-minor-mode-map): Make remapped `undo' update
+ highlighted edits in the macroexpansion buffer.
+ (slime-eval-macroexpand-in-place): Update highlighted edits when
+ macroexpanding in-place.
+ (slime-eval-macroexpand): Reuse macroexpansion buffer if it exists
+ already to preserve `undo' functionality.
+
+2006-05-30 Tobias Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-use-autodoc-mode): Fix typo in docstring.
+ (slime-use-highlight-edits-mode): New variable, analogous to
+ SLIME-USE-AUTODOC-MODE.
+ (slime-setup, slime-lisp-mode-hook): Make above variable
+ work. Also, activates the HIGHLIGHT-EDITS-MODE in proper way (thus
+ avoiding the nasty "Toggling ... off; better pass an explicit
+ argument." message.)
+
+ * slime.el: Fix typo in comment about communication protocol.
+
+2006-05-27 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * swank-abcl: slot-boundp-using-class slot-value-using-class so you
+ can inspect instances
+
+2006-05-26 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-eval-macroexpand-inplace): Fix out-of-range
+ error on in-place macroexpand when point is placed at a closing
+ parenthesis. In this case the sexp closed by that paren is
+ expanded.
+ Also make expanding of expressions work that are quoted like, for
+ instance, "'(FOO BAR)" if point is placed at the opening paren.
+
+2006-05-24 Brian Downing <bdowning(a)lavos.net>
+
+ * swank.lisp (recursively-compute-most-completions & friends):
+ Micro-optimize the fuzzy completion engine, improving performace
+ by a factor of about 4 on SBCL. However, it will only work on
+ simple-strings now, and CHAR= is burned in instead of being an
+ option. I don't think this is too much of a limitation. At this
+ point rendering the results on the emacs side takes much longer
+ than finding them for long result lists.
+
+2006-05-24 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * swank-abcl: Add some more mop functions to you can inspect classes,
+ generic functions, methods, slots.
+
+2006-05-16 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-repl-return-behaviour): New variable which
+ controls slime-repl-return's heaviour.
+ (slime-repl-return): Respect slime-repl-return-behaviour.
+
+2006-05-14 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-macroexpansion-minor-mode-map): Rebind 'undo' to
+ set buffer-read-only temporarily to t.
+ (slime-repl-return): Only send repl input if point is past a
+ complete form.
+
+2006-05-12 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (update-indentation-information): Fix for problem
+ with Allegro CL 8.0: If I type M-x slime-update-indentation,
+ Allegro CL starts growing until it hits a STORAGE-CONDITION or
+ even segfaults.
+
+2006-05-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank-allegro.lisp (fspec-definition-locations): Handle
+ :top-level-form entries that appear in backtraces.
+
+2006-04-20 Marco Baringer <mb(a)bese.it>
+
+ * swank-openmcl.lisp (toggle-trace): Implemented. Currently only
+ provides 'best effort' support, :labels and :flet are ignored,
+ :defmethod and :call are treated like a normal trace of the
+ operator.
+
+2006-04-20 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (*use-dedicated-output-stream*): Make it nil by
+ default to avoid race conditions.
+
+2006-04-19 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * doc/Makefile (contributors.texi): use texinfo macros for
+ accented characters.
+
+ * ChangeLog: canonize Gabor Melis' spelling, otherwise he appears
+ twice in the "Hackers of the good Hack table"
+
+ * doc/slime.texi (nyorsko): delete
+ (EDITION): make it say 2.0
+
+2006-04-19 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank.lisp (decoded-arglist-to-string): if the keyword and the
+ variable are different, print the keyword name with escapes.
+ (encode-keyword-arg): get the keyword and the arg-name the same
+ way round as in lambda lists.
+ (appliable-methods-keywords): use
+ swank-mop:compute-applicable-methods-using-classes and
+ compute-applicable-methods in the AMOP-friendly way, to get EQL
+ specializers right.
+ (class-from-class-name-form, extra-keywords/slots): new.
+ (extra-keywords/make-instance): use new functions. Also get
+ keywords from SHARED-INITIALIZE (after Dan Barlow) and
+ ALLOCATE-INSTANCE.
+ (extra-keywords/change-class): new.
+ (extra-keywords (eql 'change-class)): new. Won't work at present,
+ just as the CERROR case doesn't work.
+
+2006-04-19 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank-sbcl.lisp (preferred-communication-style): Make it nil
+ under win32, for now.
+
+ * doc/slime.texi: document nil *communication-style*
+
+2006-04-18 Espen Wiborg <espenhw(a)grumblesmurf.org>
+
+ * swank-corman.lisp: Define a class file-stream to let swank.lisp
+ load.
+
+2005-04-17 Andras Simon <andras(a)renyi.hu>
+
+ * swank-abcl.lisp: (accept-connection): New argument: timeout.
+
+2006-04-14 Gerd Flaig <gefla(a)pond.sub.org>
+
+ * slime.el (slime-autodoc): Fix reference to unbound variable.
+
+2006-04-13 Martin Simmons <martin(a)lispworks.com>
+
+ * swank-loader.lisp (load-site-init-file, swank-source-files): Fix
+ pathname construction to take all unspecified components from the
+ directory pathname, in particular the drive letter on Windows.
+
+2006-04-13 Helmut Eller <helmut(a)common-lisp.net>
+
+ * slime.el (slime-find-filename-translators): Use assoc-if instead
+ of assoc-default for XEmacs compatibility.
+ (slime-show-note-counts): Don't show the highlighting bit as it
+ spills of the screen.
+ (slime-highlight-notes): Use with-temp-message.
+ (with-temp-message): Define it for XEmacs.
+ (slime-beginning-of-symbol): Use eq instead of char-equal as
+ char-equal signals an error at the beginning of a buffer.
+
+2006-04-13 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-scl (make-socket-io-stream): set the stream to ignore
+ character conversion errors, and to substitute the character #\?.
+ Without this the communication channel is prone to lockup when a
+ conversion error occurs.
+
+ * swank-scl (inspect-for-emacs function): correct the index into the
+ closure environment; it was reading off the end of the closure
+ environment and picking up a corrupting value.
+
+ * swank-scl (mailbox): rework the mailbox implementation to better
+ handle interruption. Use a polling loop rather than condition
+ variables because interrupting a condition variable wait leaves the
+ thread with the condition variable lock held and leads to a deadlock
+ error.
+
+2006-04-12 Robert Macomber <slime(a)rojoma.com>
+
+ * swank-backend.lisp (make-recursive-lock): New interface
+ function.
+ (call-with-recursive-lock-held): New interface function.
+
+ * swank-grey.lisp (class slime-output-stream): Added recursive
+ locking to class and generic functions specialized on it.
+ (clss slime-input-stream): Added recursive locking to class and
+ generic functions specialized on it.
+
+ * swank-sbcl.lisp (make-recursive-lock): Implement the new interface.
+ (call-with-recursive-lock): Implement the new interface.
+
+2006-04-01 Matthew D. Swank <akopa(a)charter.net>
+
+ * slime.el (slime-fontify-string): Use set-text-properties, not
+ propertize, for Emacs 20 compatibility.
+
+2006-03-30 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-init-command): Don't translate filenames since
+ the new scheme doesn't work without a connection.
+ (slime-to-lisp-filename,slime-from-lisp-filename): Remove some
+ redundancy.
+ (slime-macroexpansion-minor-mode): Make it Emacs 20 compatible.
+
+2006-03-29 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-repl-mode): Enable autodoc-mode if
+ slime-use-autodoc-mode is true.
+
+2006-03-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (multiple-value-or): New macro.
+
+ * slime.el (slime-recently-visited-buffer): Ignore internal
+ buffers (starting with a space), to avoid selecting the
+ *slime-fontify* buffer. Reported by Andreas Fuchs.
+
+ * slime.el (slime-enclosing-operator-names): Handle forms similar
+ to make-instance (make-condition, error, etc.), to get extra
+ keywords based on the condition class.
+
+ * swank.lisp (operator-designator-to-form): Handle forms similar
+ to make-instance (make-condition, error, etc.)
+ (extra-keywords/make-instance): New function.
+ (extra-keywords): Specialize on operators make-condition, error,
+ signal, warn, cerror. Use multiple-value-or.
+
+2006-03-27 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-make-tramp-file-name): If emcas' tramp has
+ tramp-multi-methods then pass the method parameter to
+ tramp-make-tramp-file-name, otherwise don't.
+ (slime-create-filename-translator): Use
+ slime-make-tramp-file-name.
+
+2006-03-27 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * hyperspec.el (common-lisp-hyperspec-strip-cl-package): New
+ function.
+ (common-lisp-hyperspec): Don't get confused by a cl: or
+ common-lisp: package prefix.
+
+ * slime.el (slime-hyperspec-lookup): Don't get confused by a cl:
+ or common-lisp: package prefix.
+
+2006-03-26 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-enclosing-operator-names): Fix for situation
+ when point is at end of buffer, as it happens often in the REPL.
+
+2006-03-25 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (arglist-for-echo-area): New keyword arg,
+ print-lines.
+ (decoded-arglist-to-string): New function, implement argument
+ highlighting also for &optional and &rest/&body arguments.
+ (arglist-to-string): Use decoded-arglist-to-string.
+ (arglist): New slots aux-args, known-junk, unknown-junk.
+ (nreversef): New macro.
+ (decode-arglist, encode-arglist): Refine to handle more structure
+ in argument lists, including implementation-defined stuff like
+ &parse-body.
+ (format-arglist-for-echo-area): New keyword arg, print-lines.
+ Simplify the code as there is no need to fall back to the unparsed
+ arglist any more.
+
+ * slime.el (slime-fontify-string): Fix for arguments spanning
+ multiple lines.
+ (slime-autodoc-message-dimensions): New.
+ (slime-autodoc-thing-at-point): Use it here to either ask for a
+ one-line or a nicely formatted multi-line arglist.
+ (slime-enclosing-operator-names): Handle linebreaks.
+
+2006-03-24 Mikel Bancroft <mutandiz(a)yahoo.com>
+
+ * swank-allegro.lisp (set-default-directory): Fix for pathnames
+ without a trailing slash.
+
+2006-03-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-background-activities-enabled-p): Allow
+ "background activities" in sldb-mode.
+ (slime-autodoc-message-ok-p): Allow autodoc in sldb-mode.
+ (sldb-mode-syntax-table): New variable.
+ (sldb-mode): Enable autodoc-mode when slime-use-autodoc-mode is
+ true. Use sldb-mode-syntax-table to make #<...> balance like
+ parentheses. This enables autodoc-mode to match #<unreadable>
+ actual arguments in the backtraces with formal arguments of the
+ function.
+ (slime-beginning-of-symbol, slime-end-of-symbol): Handle
+ es::|caped| symbols.
+ (slime-enclosing-operator-names): Use syntax table to check
+ whether we are at the beginning of a balanced expression.
+
+2006-03-23 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank.lisp (ed-in-emacs): Allow conses as function names.
+ Ensure that there is a connection to emacs before sending the
+ :ed message.
+
+ * slime.el (slime-edit-definition): read names, not symbols.
+ (slime-ed): handle conses whose car is not a string as function
+ names.
+
+2006-03-23 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-qualify-cl-symbol-name): Strip leading colon
+ from package names for qualifying symbols.
+ (slime-call-defun): New command.
+ (slime-keys): Bind it to C-c C-y.
+ (slime-easy-menu): Show it in the menu.
+
+ * slime.el (slime-autodoc-use-multiline-p): New defcustom.
+ (slime-autodoc-message): Use it here. Fix bug that autodoc
+ messages exceeding one line could not be overwritten by later
+ autodoc messages.
+ (slime-autodoc-pre-command-refresh-echo-area): Use message
+ rather than slime-background-message.
+
+ * swank.lisp (casify): Removed.
+ (casify-char, tokenize-symbol-thoroughly): New functions.
+ (parse-symbol): Use tokenize-symbol-thoroughly, so as to handle
+ |escaped symbols|. This fixes arglist display for operators with
+ strange symbol names.
+
+2006-03-23 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-backend (accept-connection): add a 'timeout argument to
+ this function.
+
+ * swank-backend (set-stream-timeout): new implementation specific
+ function. Used to set the timeout for stream operations, which
+ can help make the network connection establishment more robust.
+
+ * swank (setup-server): ignore errors from the function 'serve to
+ allow another connection to be made.
+
+ * swank (serve-connection): ensure the listener socket is closed
+ when 'dont-close is false, even if the connection attempt fails.
+
+ * swank (accept-authenticated-connection): ensure the new
+ connection is closed if the connection establishment fails. Set a
+ short stream timeout to prevent denial of survice.
+
+ * swank (open-dedicated-output-stream): ensure the listener socket
+ is closed, even if unable to open the dedicated stream. Implement
+ a timeout while waiting for a connection for the dedicate stream
+ to prevent denial of service.
+
+ * swank (create-connection): ensure the new connection is closed
+ if not successful.
+
+2006-03-22 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (arglist-for-echo-area): Fix when arg-indices are
+ not given.
+
+ * slime.el (slime-ed): Handle (FILENAME :charpos CHARPOS).
+
+ * swank.lisp (inspect-for-emacs): Specialize on FILE-STREAM and
+ STREAM-ERROR, offering to visit the file at the current stream
+ position as an inspector action. Useful for dealing with reader
+ errors.
+
+2006-03-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-autodoc-pre-command-refresh-echo-area):
+ Show the last autodoc message again (movement commands clear it);
+ technique to avoid flickering, taken from eldoc.
+ (slime-autodoc-mode): Install it as a pre-command-hook.
+ (slime-autodoc-last-message): New variable.
+ (slime-autodoc-message): New function.
+ (slime-autodoc): Use them here.
+ (slime-autodoc-message-ok-p): OK to overwrite an autodoc message.
+
+ * slime.el (slime-handle-indentation-update): Also update
+ scheme-indent-function if slime-lisp-modes contains scheme-mode.
+
+2006-03-19 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Highlight the formal argument corresponding to the actual
+ argument around point in the echo-area arg-list display.
+ Works most impressively when slime-autodoc-mode is enabled
+ and when one has to deal with extremely long argument lists.
+
+ * slime.el (slime-space): First insert the space, then obtain
+ information.
+ (slime-fontify-string): Also handle argument highlights.
+ (slime-enclosing-operator-names): As a secondary value, return a
+ list of the indices of the arguments to the nested operator.
+ (slime-contextual-completions): Use changed interface of
+ slime-enclosing-operator-names.
+ (slime-function-called-at-point): Removed.
+ (slime-function-called-at-point/line): Removed.
+ (slime-autodoc-thing-at-point): New.
+ (slime-autodoc): Re-implement with slime-enclosing-operator-names
+ instead of slime-function-called-at-point.
+ (slime-echo-arglist): Pass the argument indices to
+ arglist-for-echo-area.
+ (slime-autodoc-message-ok-p): Autodoc is also OK in REPL buffers.
+
+ * swank.lisp (arglist-for-echo-area): New keyword argument
+ arg-indices.
+ (arglist-to-string): New keyword argument highlight.
+ (format-arglist-for-echo-area): Likewise.
+
+2006-03-18 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-goto-location-buffer): Avoid calling the
+ expensive function find-file-noselect when we are already in the
+ right buffer.
+
+ * swank.lisp (arglist-for-echo-area): Add keyword argument
+ print-right-margin.
+ (arglist-to-string, format-arglist-for-echo-area): Likewise.
+ * slime.el (slime-autodoc): Use it here to make use of the whole
+ width of the echo area for arglist display.
+
+2006-03-16 G�bor Melis <mega(a)hotpop.com>
+
+ * swank-allegro.lisp (inspect-for-emacs): Fix typo.
+
+2006-03-16 Gary King <gwking(a)metabang.com>
+
+ * swank-loader.lisp (lisp-version-string): Modified swank-loader
+ so that Allegro's alisp and mlisp programs get different
+ locations. Otherwise mlisp complains about alisp's files.
+
+2006-03-16 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-to-lisp-filename): Call expand-file-name before
+ passing the filename to the to-lisp function.
+
+2006-03-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-system-history): New variable.
+ (slime-read-system-name): Use a separate history list for ASDF
+ system names.
+ (slime-note-counts-message): New variable.
+ (slime-show-note-counts): Store the note counts message for later use.
+ (slime-highlight-notes, slime-list-compiler-notes): Show a
+ progress message, keeping note counts visible.
+ (slime-find-buffer-package): Handle IN-PACKAGE forms that appear
+ in SWIG/Allegro CL wrappers.
+
+ * swank-allegro.lisp (compile-from-temp-file): Suppress Allegro's
+ redefinition warnings; they are pointless when we are compiling
+ via a temporary file.
+ (profile-report): Implement.
+
+2006-03-06 Nathan Bird <nathan(a)acceleration.net>
+
+ * slime.el (slime-create-filename-translator): use the tramp
+ methods for dissecting and building filenames.
+
+2006-03-04 Wojciech Kaczmarek <wojtekk(a)kofeina.net>
+
+ * slime.el (slime-filename-translations): Typo in example.
+ (slime-create-filename-translator): Typo in generated lambdas.
+
+2006-03-03 Marco Baringer <mb(a)bese.it>
+
+ Allow per-host (per machine-instance actually) filename
+ translation functions.
+
+ * slime.el (slime-translate-to-lisp-filename-function): removed.
+ (slime-translate-from-lisp-filename-function): removed.
+ (slime-filename-translations): New variable.
+ (slime-to-lisp-filename): Rewrote to search through available
+ transalations.
+ (slime-from-lisp-filename): idem.
+ (slime-create-filename-translator): New function.
+ (slime-add-filename-translation): New function.
+
+2006-02-27 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-eval-macroexpand-inplace): Indent the inserted
+ macroexpansion.
+
+2006-02-27 Marco Baringer <mb(a)bese.it>
+
+ Provide functions for performing macroexpansion inplace, use these
+ functions in the *SLIME macroexpansion* buffer.
+
+ * slime.el (slime-macroexpansion-minor-mode): Attempt to map
+ -inplace functions to the same keys as their regular contureparts
+ in slime-mode-map.
+ (slime-eval-macroexpand-inplace): New function.
+ (slime-macroexpand-1-inplace): New function.
+ (slime-macroexpand-all-inplace): New function.
+ * doc/slime.texi: Document new macroexpansion mode.
+
+2006-02-26 Douglas Crosher <dcrosher(a)common-lisp.net>
+ * swank-scl.lisp: (ext:stream-read-chars): Correct the updating of
+ the buffer index. Fixes slime input stream problems.
+
+2006-02-25 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-loader.lisp (default-fasl-directory): Previously we return
+ only the directory-namestring which breaks SCL, because it loses
+ the host and device components. Return the complete pathname
+ instead. Patch by Douglas Crosher.
+
+ * slime.el (slime-lisp-host): New variable. Replace all references
+ to "127.0.0.1" with the variable.
+
+2006-02-25 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-backend.lisp (operate-on-system): symbol case fix for
+ SCL's lowercase mode.
+
+ * swak.lisp (setup-stream-indirection)
+ (globally-redirect-io-to-connection)
+ (revert-global-io-redirection): symbol case fixes.
+
+ * swank-scl.lisp: (inspect-for-emacs): Fixes for the inspect
+ standard-objects, and inspect array. Plus misc symbol case fixes.
+
+2006-02-22 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-repl-send-input): Don't include the final
+ newline in the slime-repl-input-face overlay, thus avoid showing the
+ "Evaluation aborted" message in boldface. Don't set non-existent
+ "rear-nonsticky" overlay property; overlay stickiness is
+ controlled by make-overlay arguments.
+
+2006-02-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Use argument list information to complete keywords contextually.
+ Example: (find 1 '(1 2 3) :s <M-TAB> --completes--> :start
+ rather than suggesting all ever-interned keywords starting with ":s".
+
+ * slime.el (slime-complete-keywords-contextually): New
+ customizable variable.
+ (slime-enclosing-operator-names): New optional argument
+ max-levels.
+ (slime-completions-for-keyword): New.
+ (slime-contextual-completions): New.
+ (slime-expand-abbreviations-and-complete): Use it instead of
+ slime-completions.
+
+ * swank.lisp (operator-designator-to-form): New, factored out from
+ arglist-for-echo-area.
+ (arglist-for-echo-area): Use it here.
+ (completions-for-keyword): New.
+ (find-matching-symbols-in-list): New.
+
+2006-02-19 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-expand-abbreviations-and-complete): Scroll the
+ completions buffer if the TAB key is pressed another time, like
+ Emacs minibuffer completion does.
+
+2006-02-18 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-macroexpansion-minor-mode): New minor mode for
+ macroexpansion buffer. Exactly like slime-temp-buffer-mode but
+ with slime-macroexpand-again bound to "g".
+ (*slime-eval-macroexpand-expression*): New variable. introduced
+ for slime-macroexpand-again, used by slime-eval-macroexpand as
+ well.
+ (slime-eval-macroexpand): Added optional string argument which
+ defaults to (slime-sexp-at-point-or-error).
+ (slime-macroexpand-again): New function, redoes the last
+ macroexpansion.
+ (slime-sexp-at-point-or-error): New function. Like
+ slime-sexp-at-point but signals an error when slime-sexp-at-point
+ would return nil.
+ * swank-openmcl.lisp (swank-mop:compute-applicable-methods-using-classes):
+ Implement.
+
+2006-02-16 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * sbcl-pprint-patch.lisp: New file, adds the annotations feature
+ to the SBCL pretty printer. This is needed for sending
+ presentations through pretty-printing streams.
+ * present.lisp [sbcl]: Load it here.
+ (slime-stream-p, write-annotation) [sbcl]: Handle pretty-streams.
+
+2006-02-10 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-allegro.lisp, swank-lispworks.lisp (inspect-for-emacs):
+ Use the backend specific method to inspect standard-objects
+ because {slot-boundp,slot-value}-using-class don't conform to the
+ MOP spec in LW and ACL.
+
+ * swank.lisp (macro-indentation): Don't count '&optional as
+ argument.
+
+ * swank-loader.lisp (default-fasl-directory): Include the SLIME
+ version.
+ (slime-version-string): New.
+
+2006-02-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Show enriched arglists for DEFMETHOD in the echo area when the
+ user types SPC after the generic function name.
+
+ * swank.lisp (arglist-to-template-string): Unused, removed.
+ (extra-keywords): Indicate which part of the actual arglist was
+ used to determine the extra keywords. For MAKE-INSTANCE, don't
+ signal an error if the class does not exist.
+ (enrich-decoded-arglist-with-extra-keywords): Indicate which part
+ of the actual arglist was used to determine the extra keywords,
+ and whether any extra keywords were added.
+ (form-completion): Generalize to handle display of enriched formal
+ arglists.
+ (read-incomplete-form-from-string): New, factored out from
+ complete-form. Handle end-of-file.
+ (complete-form): Use it here.
+ (format-arglist-for-echo-area): Use form-completion, so as to
+ show enriched formal arglists for MAKE-INSTANCE and DEFMETHOD
+ calls.
+ (arglist-for-echo-area): Handle MAKE-INSTANCE and DEFMETHOD
+ calls.
+
+ * slime.el (slime-enclosing-operator-names): Represent
+ MAKE-INSTANCE calls by (:make-instance "CLASS-NAME"), handle
+ DEFMETHOD too.
+
+2006-02-05 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-complete-form): Indent the inserted template.
+
+2006-02-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-fontify-string): New.
+ (slime-echo-arglist, slime-arglist, slime-autodoc): Use it here to
+ fontify echo-area arglists.
+
+2006-02-02 Marco Baringer <mb(a)bese.it>
+
+ * swank-openmcl.lisp: Added imports for slot-boundp-using-class,
+ slot-value-using-class and finalize-inheritance.
+
+2006-02-01 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-abcl.lisp: define with-compilation-hooks (= funcall for now), so that you can do slime-oos
+
+2006-01-30 Ian Eslick <eslick(a)csail.mit.edu>
+
+ Show slot values for metaclasses that override the default storage
+ locations for objects slots (i.e. where the default slot-boundp
+ returns nil) in the inspector.
+
+ * swank.lisp (inspect-for-emacs standard-object): Use
+ slot-value-using-class and slot-boundp-using-class.
+
+ * swank-backend.lisp: Add slot-value-using-class and
+ slot-boundp-using-class to the swank-mop package.
+
+2006-01-26 Lu�s Oliveira <loliveira(a)common-lisp.net>
+
+ * slime.el (slime-enclosing-operator-names): detect make-instance
+ forms and collect the class-name argument if it exists and is a
+ quoted symbol.
+
+ * swank.lisp (arglist-for-echo-area): handle pairs of of the form
+ ("make-instance" . "<class-name>") by passing them to
+ format-initargs-and-initforms-for-echo-area.
+ (class-initargs-and-iniforms): New function.
+ (format-initargs-and-initforms-for-echo-area): New function.
+
+2006-01-20 M�sz�ros Levente <melevy(a)freemail.hu>
+
+ * swank-sbcl.lisp (restart-frame): Provide an implementation even
+ if it doesn't quite do what it's supposed to do.
+
+2006-01-19 Helmut Eller <heller(a)common-lisp.net>
+
+ Return to the previous loading strategy: load everything when
+ swank-loader is loaded. It's just to convenient to give that up.
+ To customize the fasl directories, the new variable
+ swank-loader:*fasl-directory* can be set before loading
+ swank-loader.
+
+ * swank-loader.lisp (*fasl-directory*, *source-directory*): New
+ variables.
+ (load-swank): Call it during loading.
+
+2006-01-14 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-compile-defun): If point was at the opening
+ paren we wrongly used the preceding toplevel form. Fix it.
+ Reported by Chisheng Huang and Liam M. Healy.
+
+ * swank.lisp (spawn-threads-for-connection): Fix a race condition:
+ Don't accept input before all threads are ready.
+
+ Make the fasl directory customizable: load-swank must now be
+ called explicitly so that we can supply the fasl dir as argument.
+
+ * swank-loader.lisp (load-swank): New entry point.
+
+2006-01-14 Andreas Fuchs <asf(a)boinkor.net>
+
+ * slime.el (slime-selector ?r): Call slime instead of slime-start
+ to pick up the usual defaults.
+
+2005-12-31 Harald Hanche-Olsen <hanche(a)math.ntnu.no>
+
+ * slime.el (slime-open-stream-to-lisp): Inherit the
+ process-coding-system from the current connection.
+
+2005-12-27 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-abcl. (backtrace-as-list-ignoring-swank-calls): remove the
+ swank calls from the backtrace to make it easier to use.
+ (frame-locals): Fix a typo that caused entry into the debugger if
+ you tried to look at frame locals. Now you don't error out, but
+ you still don't see frame locals because I don't know how to get
+ them :(
+
+2005-12-27 Helmut Eller <heller(a)common-lisp.net>
+
+ Keep a history of protocol events for better bug reports.
+
+ * swank.lisp (log-event): Record the event in the history buffer.
+ (*event-history*): Buffer for events.
+ (dump-event-history): New function.
+ (close-connection): Escape non-ascii strings and include the event
+ history in the error message.
+
+2005-12-22 Helmut Eller <heller(a)common-lisp.net>
+
+ Make highlighting of modified text a minor mode. Also use
+ after-change-functions instead of rebinding all self-inserting
+ keys.
+
+ * slime.el (slime-highlight-edits-mode): New minor mode.
+ (slime-self-insert-command): Deleted.
+ (slime-before-compile-functions): New hook to decouple edit
+ highlighting from compilation.
+ (slime-highlight-edits-face): Renamed from slime-display-edit-face.
+
+2005-12-20 Marco Baringer <mb(a)bese.it>
+
+ When inspecting classes, methods and generic functions show all
+ the slots in the case that what we're inspecting is a subclass of
+ the standard class and has extra user defined slots.
+
+ * swank.lisp (all-slots-for-inspector): New function.
+ (inspect-for-emacs): Use all-slots-for-inspector.
+
+2005-12-19 Peter Seibel <peter(a)gigamonkeys.com>
+
+ * slime.el (slime-self-insert-command): Got rid of message about
+ setting up face and skipping edit-hilights when in a comment.
+
+2005-12-18 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * slime.el (slime-mode-hook): Bind simple characters to
+ slime-self-insert-command only if there was no previous local
+ binding, and the major mode is _not_ slime-repl-mode. This
+ restores keybindings of slime-xref-mode and prevents us from
+ stomping on user bindings. The hilighting also makes no sense in
+ the REPL.
+
+2005-12-16 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * slime.el (slime-selector-method: ?r): If no connection offer to
+ start Slime.
+
+ * swank.lisp (to-string): Handle errors from printing objects.
+ Among other things makes the inspector more robust in the face of
+ objects with unbound slots and print-methods that fail to cope.
+
+2005-12-16 William Bland <doctorbill.news(a)gmail.com>
+
+ Added hilighting of tetx which has been edited but not yet
+ compilied.
+
+ * slime.el (slime-display-edit-hilights): New variable.
+ (slime-display-edit-face): New face.
+ (slime-compile-file, slime-compile-defun, slime-compile-region):
+ Remove edits overlay.
+ (slime-remove-edits): New function.
+ (slime-self-insert-command): New function.
+ (slime-mode-hook): Rebind simple characters to
+ slime-self-insert-command.
+
+2005-12-07 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank-allegro.lisp (find-definition-in-file)
+ (find-fspec-location, fspec-definition-locations): Allegro CL
+ properly records all definitions made by arbitrary macros whose
+ names start with "def". Use excl::find-source-file and
+ scm:find-definition-in-definition-group (rather than
+ scm:find-definition-in-file) to find them.
+
+ * slime.el (slime-load-file): Change the default to be the buffer
+ file name with extension. This is more convenient for files like
+ .asd files that do not have the default source file extension.
+ (slime-save-some-lisp-buffers, slime-update-modeline-package):
+ Handle all files with major mode in slime-lisp-modes, not just
+ lisp-mode.
+
+2005-12-06 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (function-source-location,
+ safe-function-source-location): Oops, define these functions also
+ for the >0.9.6 case. Fixes broken sldb-show-source on SBCL 0.9.7.
+
+2005-12-05 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-find-coding-system): Use check-coding-system
+ only if it's actually fbound.
+
+2005-11-22 Marco Monteiro <masmxx(a)gmail.com>
+
+ * slime.el (slime-connect): Use slime-net-coding system if the
+ optional arg coding-system was not supplied.
+
+2005-11-22 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-compile-file): Call 'check-parens before
+ compiling.
+ (slime-compile-file): Call 'check-parens before compiling.
+ (slime-find-coding-system): Return nil if the coding system
+ isn'tvalid instead of singalling an error.
+ (slime-repl-history-file-coding-system): Use
+ slime-find-coding-system to find the default.
+
+ * swank-cmucl.lisp (accept-connection): Remove fd-handlers if the
+ encoding isn't iso-latin-1.
+
+2005-11-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-start): Don't set slime-net-coding-system ..
+ (slime-read-port-and-connect): .. read it from the inferior lisp args.
+ (slime-connect): Take the coding-system as third argument.
+ (slime-repl-history-file-coding-system): New user option.
+ (slime-repl-safe-save-merged-history): New function. Use it in
+ hooks so that bad coding systems don't stop us from exiting.
+ (slime-repl-save-history): Include the coding-system which was
+ used to save the buffer.
+ (repl-shoctut change-package): Add alias ,in and ,in-package.
+ (slime-eval-macroexpand): Error out early if there's no sexp at
+ point.
+ (slime-compiler-macroexpand): New command.
+ (slime-inspector-pprint): New command.
+
+ * swank-cmucl.lisp (inspect-for-emacs): Add support for
+ funcallable instances.
+
+ * swank.lisp (pprint-inspector-part, swank-compiler-macroexpand): New.
+
+ * swank-backend.lisp (compiler-macroexpand)
+ (compiler-macroexpand-1): New functions.
+
+2005-11-14 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-scl.lisp (accept-connection): handle the :buffering argument.
+
+2005-11-13 Andras Simon <andras(a)renyi.hu>
+
+ * swank-abcl.lisp: (accept-connection): New argument: buffering.
+
+2005-11-13 Andras Simon <andras(a)renyi.hu>
+
+ * swank-abcl.lisp: Steal auto-flush stuff from swank-sbcl.lisp
+
+2005-11-11 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (*dedicated-output-stream-buffering*): New variable
+ to customize the buffering scheme. For single-threaded Lisps we
+ disable buffering because lazy programmers forget to call
+ finish-output.
+ (open-dedicated-output-stream): Use it.
+
+ * swank-backend.lisp, swank-allegro.lisp, swank-lispworks.lisp,
+ swank-openmcl.lisp, swank-cmucl.lisp, swank-sbcl.lisp,
+ swank-clisp.lisp, swank-abcl.lisp, swank-corman.lisp,
+ swank-ecl.lisp (accept-connection): New argument: buffering.
+
+ * slime.el (slime-repl-save-history): When the history exceeds
+ slime-repl-history-size remove the old not the new entries.
+ Some renaming:
+ slime-repl-read-history -> slime-repl-load-history,
+ slime-repl-read-history-internal -> slime-repl-read-history.
+ (slime-eval-macroexpand): Call font-lock-fontify-buffer
+ explicitly, because with certain Emacs versions the buffer doesn't
+ get fontified immediately.
+
+2005-11-07 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-eval-macroexpand): Use lisp-mode (and
+ font-lock-mode) when dispaying the expansion. Suggested by Jan
+ Rychter.
+
+ * swank-source-path-parser.lisp (make-source-recording-readtable):
+ Suppress the #. reader-macro.
+
+2005-11-06 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (find-definitions, make-source-location-specification
+ make-definition-source-location, source-hint-snippet): As of
+ SBCL 0.9.6.25 SB-INTROSPECT has better support for finding
+ source locations. Use as much of it in swank-sbcl as possible.
+ (Original version left reader-conditionalized for older SBCLs).
+
+2005-11-04 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (connection-info): Docfix.
+
+ * slime.el (slime-set-connection-info): Generate a new connection
+ name only if the implementation-name and the inferior-lisp-name
+ are different.
+
+2005-10-31 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-start, slime-lookup-lisp-implementation)
+ (slime-set-connection-info): Add a :name property for the
+ implementation and use it to derive the connection-name.
+ (slime-lisp-implementation-name): Renamed from
+ slime-lisp-implementation-type-name.
+
+ * swank.lisp (simple-serve-requests): Add an extra abort restart.
+ (connection-info): Rename :type-name to :name.
+
+2005-10-30 Andras Simon <andras(a)renyi.hu>
+
+ * swank-abcl.lisp (inspect-for-emacs): Track mop changes in ABCL.
+
+2005-10-30 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-eval): Ensure that the connection is open before
+ waiting for input.
+
+ * swank.lisp (simple-serve-requests): Close the connection at the
+ end.
+
+2005-10-23 Harald Hanche-Olsen <hanche(a)math.ntnu.no>
+
+ * slime.el (slime-init-keymaps): Use vectors when defining keys,
+ because e.g. (define-key (string ?\C-c) ...) doesn't work in the
+ emacs-unicode-2 branch.
+
+2005-10-23 Stefan Kamphausen <skampi(a)gmx.net>
+
+ * slime.el (slime-repl-history-size, slime-repl-history-file): Use
+ defcustom to declare the variables.
+
+2005-10-23 G�bor Melis <mega(a)hotpop.com>
+
+ * swank-backend.lisp (install-debugger-globally): new interface
+ function
+
+ * swank.lisp (install-debugger): call install-debugger-globally
+
+ * swank-sbcl.lisp (install-debugger-globally): set
+ sb-ext:*invoke-debugger-hook* too
+
+2005-10-23 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-sbcl.lisp (make-stream-interactive): Spawn a thread to
+ flush interactive streams in reasonably short intervals.
+ Remove the old backward-compatible threading implementation.
+
+ * swank.lisp (package-string-for-prompt): Respect *print-case*.
+
+2005-10-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-start-swank-server): Avoid comint-send-input
+ here as it seems to trigger a bug in ansi-color-for-commit-mode.
+
+2005-10-18 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank.lisp (canonical-package-nickname): always return the
+ package name as a STRING if found. This restores the printing of
+ package names as strings.
+
+2005-10-17 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (eval-in-emacs): Instead of taking a string and
+ attempting to parse it emacs side the function now takes a form
+ and converts it to a string internally. This should allow users of
+ the function to not have to worry about quoting issues and emacs'
+ different printed represenation for, among other things,
+ characters.
+ (process-form-for-emacs): New function. Converts a list into a
+ string for passing to emacs.
+
+ * slime.el (slime-eval-for-lisp): New API. This function now takes
+ a single string, representing the form to evaluate, and uses
+ emacs' read function to convert it into a form before eval'ing it.
+ (slime-dispatch-event): The :eval event now passes a single
+ string (instead of a string and something looking kind of like a
+ form).
+
+2005-10-15 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-scl.lisp: Support for Scieneer Common Lisp.
+
+ * swank-backend.lisp (*gray-stream-symbols*) Scieneer Common Lisp
+ implements stream-line-length.
+
+ * swank-loader.lisp: Support for Scieneer Common Lisp:
+ (*sysdep-pathnames*) use swank-scl.
+ (*impl ementation-features*) add :scl.
+ (*os-features*) add :hpux.
+ (*architecture-features*) add :amd64, :i686, :i486, :sparc64, :sparc,
+ :hppa64, and :hppa.
+
+ * swank.lisp: (*canonical-package-nicknames*) use lowercase
+ symbols to name the packages. This supports CL implementations
+ with lowercase default symbol names, such as Scieneer Common Lisp,
+ while still being compatible with ANSI-CL.
+
+2005-10-11 Stefan Kamphausen <skampi(a)gmx.net>
+
+ * slime.el: Persistent REPL history. The history from REPL
+ buffers is now saved to the file ~/.slime-history.eld. The file
+ is read on startup and saved when a REPL buffer gets killed or
+ when Emacs exits. There are also commands to save or read the
+ history file.
+ (slime-repl-save-merged-history, slime-repl-merge-histories)
+ (slime-repl-read-history, slime-repl-save-history): New functions.
+ (slime-repl-history-file, slime-repl-history-size): New vars.
+ (slime-repl-mode): Add hooks to load and save the history.
+
+2005-10-11 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-read-interactive-args): Split the string
+ inferior-lisp-program to get the values for :program and
+ :program-args. Also let slime-lisp-implementations take
+ precedence if non-nil.
+ (slime-lisp-implementations): Renamed from
+ slime-registered-lisp-implementations.
+
+ * swank.lisp (force-user-output): There seems to be a bug in
+ Allegro's two-way-streams. As a workaround we use force-output for
+ the user-io stream. (finish-output *debug-io*) still triggers the
+ bug.
+
+2005-10-10 Svein Ove Aas <svein.ove(a)aas.no>
+
+ * swank-allegro.lisp (find-external-format): Translate :utf-8-unix
+ to :utf8, which Allegro 7.0 understands.
+
+2005-10-09 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime, slime-start): Introduce a separate function for
+ the non-interactive case. `slime-start' takes lots of keyword
+ arguments and `slime' is reserved for interactive use.
+ (slime-read-interactive-args): New function.
+ (slime-maybe-start-lisp, slime-inferior-lisp)
+ (slime-start-swank-server): Pass all arguments needed to start
+ the subprocess as a property list. Also store this list in a
+ buffer-local var in the inferior-lisp buffer, so that we can
+ cleanly restart the process.
+ (slime-registered-lisp-implementations): Change the format and
+ document it. M-- M-x slime can now be used select a registered
+ implementation.
+ (slime-symbolic-lisp-name): Deleted. And updated all the functions
+ which passed it along.
+ (slime-set-connection-info): Use the new format.
+ (slime-output-buffer): Don't re-initialize buffer-local variables
+ if the buffer already exists. This saves the history. From Juho
+ Snellman.
+
+ * swank-cmucl.lisp (sis/in): Use finish-output instead of
+ force-output.
+
+ * swank.lisp (connection-info): Include the initial package and
+ a more self-descriptive format.
+
+2005-10-01 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-backend (*gray-stream-symbols*): Add :STREAM-LINE-LENGTH
+ to *GRAY-STREAM-SYMBOLS* on implementations that support this
+ extension to gray streams. Reported by Matthew D Swank.
+
+2005-09-29 Luke Gorrie <luke(a)synap.se>
+
+ * swank-scheme48: Removed due to excessive whining.
+
+2005-09-28 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-multiprocessing): Deleted. No longer needed.
+ (slime-init-command): Updated accordingly.
+ (slime-current-package): Add a special case for Scheme.
+ (slime-simple-completions, slime-apropos): Quote the package,
+ because in can be a plain symbol in Scheme.
+ (slime-inspector-reinspect): Use a proper defslimefun.
+
+ * swank.lisp (inspector-reinspect): New function.
+ (start-server): Call initialize-multiprocessing before starting
+ the server and startup-idle-and-top-level-loops afterwards.
+ Calling startup-idle-and-top-level-loops here shouldn't be a
+ problem because start-server is only invoked at startup via stdin.
+
+ * swank-scheme48/source-location.scm: New file. For M-.
+ * swank-scheme48/module.scm (list-all-package): New function.
+ * swank-scheme48/interfaces.scm (module-control-interface): Export it.
+ * swank-scheme48/inspector.scm: Add methods for records and hashtables.
+ (swank:arglist-for-echo-area): Implement it. Only works for
+ functions with enough debug-data (ie. only user-defined functions).
+ * swank-scheme48/completion.scm: New file.
+ (swank:simple-completions, swank:apropos-list-for-emacs): Implemented.
+ * swank-scheme48/load.scm, swank-scheme48/defrectypeX.scm: Renamed
+ the file from defrectype*.scm
+ * swank-scheme48/packages.scm (swank-general-rpc): Don't use
+ posix-process because it doesn't work on Windows, and we don't need
+ it for a mulithreaded server.
+
+2005-09-22 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-backend.lisp (*gray-stream-symbols*): Collect the needed
+ symbols here, so that we don't need to mention them in every
+ backend.
+ (import-from). New function.
+
+ * swank-sbcl.lisp, swank-allegro.lisp, swank-lispworks.lisp,
+ swank-openmcl.lisp, swank-ecl.lisp: Use *gray-stream-symbols* when
+ importing the needed symbols.
+
+ * swank-gray.lisp (stream-fresh-line): Define a method, so that
+ Allegro passes our tests.
+
+2005-09-21 Aleksandar Bakic <a_bakic(a)yahoo.com>
+
+ * swank.lisp (accept-authenticated-connection): Minor fix. Ensure
+ that the decoded message is a string before calling string= on it.
+
+2005-09-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-setup-command-hooks): Make
+ after-change-functions a buffer-local variable; it's by default
+ global in XEmacs.
+
+ * swank.lisp (throw-to-toplevel): Invoke the `abort-restart'
+ request instead of throwing to the `slime-toplevel' catch tag.
+ (handle-request): Rename the restart from abort to abort-request.
+ (call-with-connection): Remove the slime-toplevel catch tag
+ because with-connection is used in far to many places which aren't
+ at "toplevel".
+
+ * present.lisp (presentation-start, presentation-end): Use
+ finish-output instead of force-output.
+
+ * swank-gray.lisp, swank-cmucl.lisp: Improve stream efficiency by
+ buffering more output. stream-force-output simply does nothing, if
+ the output buffer was flushed less than 200 millisecons before.
+ stream-finish-output can still be used to really flush the buffer.
+ (slime-output-stream): New slot last-flush-time.
+ (stream-finish-output): New function. Do what stream-force-output
+ did previously.
+ (stream-force-output): Buffer more output.
+
+ * slime.el (slime-process-available-input): Oops, don't start a
+ timer for every event.
+ (slime-write-string): Renamed from slime-output-string.
+ (slime-dispatch-event): Rename :read-output to :write-string.
+ (slime-io-speed-test): New command.
+ (slime-open-stream-to-lisp): Fix parens. The coding system should
+ also be set if presentations are disabled.
+
+ * swank.lisp (make-output-function): Rename :read-output to
+ :write-string.
+ (eval-for-emacs, interactive-eval, eval-region): Use finish-output
+ not force-output.
+
+ * swank-sbcl.lisp, swank-openmcl.lisp, swank-allegro.lisp,
+ swank-lispworks: Import `stream-finish-output'.
+
+ * swank-scheme48/io.scm (empty-swank-output-buffer): Rename
+ :read-output to :write-string.
+
+ * swank-scheme48/load.scm (slime48-start): Fix '() vs. #f bug.
+
+2005-09-19 Luke Gorrie <luke(a)synap.se>
+
+ * nregex.lisp: Released into the public domain by Lawrence E. Freil.
+
+2005-09-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime48): New command.
+
+2005-09-19 Taylor Campbell <campbell(a)mumble.net>
+
+ * swank-scheme48/: New backend.
+
+2005-09-18 Wolfgang Jenkner <wjenkner(a)inode.at>
+
+ * bridge.el: cl is required at macro expansion time (because of
+ `block'). Reported by Matthew D Swank.
+
+2005-09-18 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp: Move presentation menu protocol here from present.lisp.
+
+2005-09-15 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * slime.el (slime-repl-return) don't copy presentation to input if
+ already in input area.
+
+2005-09-15 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-clisp.lisp (compute-backtrace): Include only "function
+ frames" in the backtrace. I hope that makes some sense.
+ (sldb-backtrace, function-frame-p): New functions.
+ (*sldb-backtrace*, call-with-debugging-environment, nth-frame):
+ Compute and remember the backtrace when entering the debugger.
+ (arglist): If the function has a function-lambda-expression, fetch
+ the arglist from there.
+ (find-encoding): Use strings instead of 'charset:foo symbols to
+ avoid compile time problems if the charset is not available.
+ Suggested by Vaucher Laurent.
+
+ * swank.lisp (eval-in-emacs): Fix a race condition which occurred
+ with sigio.
+ (*echo-area-prefix*): New variable.
+
+ * slime.el (slime-process-available-input): Simplify it a bit and
+ make it easier to debug read errors.
+ (slime-net-close): Don't kill the buffer if the new optional arg
+ `debug' is true.
+ (slime-run-when-idle): Accept arguments for the function.
+ (slime-init-connection-state): Close over the proc variable. It
+ was lost when the async evaluation returned.
+ (slime-output-buffer, slime-connection-output-buffer): Make
+ slime-output-buffer faster by keeping the buffer in a connection
+ variable.
+ (slime-restart-inferior-lisp-aux, slime-quit-lisp): Disable the
+ process filter to avoid errors in XEmacs.
+
+2005-09-14 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el (slime-menu-choices-for-presentation), (slime-presentation-menu)
+ Fix loss after refactoring. xemacs can't handle lambda forms in
+ the menu spec given to x-popup-menu, only symbols, so save the
+ actions in a hash table keyed by a gensym, give x-popup-menu the
+ gensym and then call the gensym. Haven't checked that it actually
+ works in xemacs because my xemacs is hosed in os x Tiger. Could
+ someone let me know...
+
+ * swank.lisp (inspect-factor-more-action)
+ rename (inspect-show-more-action) Prompt before reading how many
+ more. Would be nicer to prompt in the minibuffer...
+
+2005-09-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-presentation-expression): Remove handling of
+ cons presentation-ids.
+
+2005-09-13 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el (defcustom slime-ed-use-dedicated-frame ... vs defvar
+
+ (defcustom slime-when-complete-filename-expand: Use
+ comint-replace-by-expanded-filename instead of
+ comint-dynamic-complete-as-filename to complete file names
+
+ * swank.lisp (run-repl-eval-hooks .. finally (return vs no return
+
+ inspector-call-nth-action Allow second value :replace for inspector actions
+
+ (defvar *slime-inspect-contents-limit* default nil. How many elements of
+ a hash table or array to show by default. If table has more than
+ this then offer actions to view more. Set to nil for no limit. Probably should
+ set default to reasonable value - I like 200.
+
+ (inspect-for-emacs ((ht hash-table) inspector)) - banner line is hash table object.
+ Respect *slime-inspect-contents-limit*
+
+ (defmethod inspect-for-emacs ((array array) inspector)
+ Respect *slime-inspect-contents-limit*
+
+ * swank-openmcl.lisp inspector for closures shows closed-over
+ values. To be fixed: inspector-princ needs to be loaded earlier
+ since swank package not available when compiling
+
+2005-09-13 Helmut Eller <heller(a)common-lisp.net>
+
+ * present.lisp (menu-choices-for-presentation-id): Use
+ lookup-presented-object secondary return value instead of
+ *not-present*.
+ (execute-menu-choice-for-presentation-id, presenting-object-1):
+ Remove references to *can-print-presentation*.
+
+ * slime.el (slime-current-output-id): Remove this ugly klugde.
+ (slime-repl-insert-result): New function. Handle the presentations
+ and other special cases cleaner.
+ (slime-repl-insert-prompt): Use it. The `result' arg is now a
+ structured list; update callers accordingly.
+ (slime-repl-return): Make the prefix arg work again.
+ (package-updating): The result of swank::listener-eval changed a
+ bit. Update the test.
+
+ Remove some unnecessary uses of `defun*' and reindent it to 80
+ columns.
+
+ * swank.lisp: Simplify the object <-> presentation-id mapping.
+ (save-presented-object): Remove the optional `id' arg.
+ (lookup-presented-object): Id should be a fixnum not some cons
+ with fuzzy/non-documented meaning. Use the secondary return value
+ to test for absence of the id. Update callers accordingly.
+ (*not-present*): Deleted.
+
+ Remove the repl result special cases, let the general presentation
+ machinery handle it.
+ (*last-repl-result-id*, add-repl-result, *current-id*)
+ (clear-last-repl-result): Deleted.
+ (listener-eval): Don't *current-id* to tag result values.
+
+ (*can-print-presentation*): Deleted. Nobody quite knows whether
+ it's still needed so let just try without it. Updated referrers
+ accordingly.
+
+ (eval-region, run-repl-eval-hooks): Move the eval hook stuff to
+ a separate function.
+
+ * swank-loader.lisp (lisp-version-string)[cmu]: Replace spaces
+ with underscores.
+
+2005-09-12 NIIMI Satoshi <sa2c(a)sa2c.net>
+
+ * swank.lisp, slime.el, swank-clisp.lisp, swank-sbcl.lisp: add
+ EUC-JP as coding system. This patch eliminates the requirement of
+ Mule-UCS to use Japanese characters. (Nice for pre-22 Emacs
+ users.)
+
+2005-09-10 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-enable-evaluate-in-emacs): Resurrected.
+ (slime-dispatch-event): Respect slime-enable-evaluate-in-emacs for
+ messages :eval-no-wait and :eval.
+
+2005-09-09 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * slime.el (slime-choose-overlay-region). Don't try to overlay a
+ note if location is nil.
+
+2005-09-08 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * bridge.el Fix bug in bridge filter where a bridge message which
+ straddled a packet would be mishandled. Sometimes this would
+ result in spurious bridge message text being inserted with the
+ presentation and the presentation not being sensitive. In other
+ cases there would be an actual error. Introduce bridge-leftovers
+ to save the last, unfinished bit for the next call, and prepend it
+ before processing a chuunk. Also, fix the parentheses so that the
+ unwind protect cleanup forms are actually in the cleanup section.
+ In openmcl, where apparently communication with slime is done in
+ 2k chunks, you can trigger the bug with something like this:
+ (swank::presenting-object 'foo t
+ (dotimes (i 2040) (write-char #\:)))
+
+ * swank-openmcl.lisp (handle-compiler-warning). Don't create a
+ location if the condition doesn't have a filename. If it does,
+ make sure you pass a string rather than a pathname object
+ otherwise you get a net-read error
+
+2005-09-07 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * present.lisp (menu-choices-for-presentation): The
+ Inspect/Describe/Copy items are now provided from the Emacs side.
+ Implement all pathname menu items without having Emacs evaluate a
+ form. Fix for Lisps where ".lisp" is parsed as :name ".lisp".
+
+ * slime.el (slime-menu-choices-for-presentation): New function,
+ return a menu with Inspect/Describe/Copy plus the items that come
+ from the menu protocol.
+ (slime-presentation-menu): Security improvement for the
+ presentation menu protocol: Don't eval arbitrary forms coming from
+ the Lisp. Minor cleanup: Use x-popup-menu in the normal Emacs way,
+ associating a command with each menu item.
+
+2005-09-05 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-cmucl.lisp (background-message): New function. Forward the
+ call to the front end.
+ (pre-gc-hook, post-gc-hook): Use it.
+ (swank-sym, sending-safe-p): Deleted.
+
+ * swank.lisp (y-or-n-p-in-emacs): Simplify arglist.
+ (evaluate-in-emacs, dispatch-event, send-to-socket-io): Remove
+ evaluate-in-emacs stuff.
+ (to-string): Undo last change. to-string is not to supposed to
+ ignore errors. Bind *print-readably* instead.
+ (background-message): New function.
+ (symbol-external-p): Simplify it a little.
+
+ * slime.el (slime-setup-command-hooks): Add after-change-functions
+ only if presentations are enabled.
+ (slime-dispatch-event, slime-enable-evaluate-in-emacs)
+ (evaluate-in-emacs): Remove evaluate-in-emacs stuff. It was not
+ used and redundant.
+ (slime-save-some-lisp-buffers): Renamed from
+ save-some-lisp-buffers.
+ (slime-choose-overlay-region): Ignore :source-form locations.
+ (slime-choose-overlay-for-sexp): Ignore errors when stepping over
+ forms.
+ (slime-search-method-location, slime-goto-location-position): Move
+ all this regexpery to its own function.
+ (slime-recenter-if-needed, slime-repl-return): Factor some
+ duplicated code into its own function.
+ (slime-presentation-bounds, slime-presentation-around-point)
+ (slime-presentation-around-or-before-point): Minor cleanups.
+
+2005-09-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-ensure-presentation-overlay): New.
+ (slime-add-presentation-properties): Don't add face, mouse-face,
+ keymap text properties. Call slime-ensure-presentation-overlay to
+ implement them via overlays.
+ (slime-remove-presentation-properties): Don't remove these text
+ properties. Delete the right overlay.
+ (slime-after-change-function): Add overlays for presentations if
+ necessary.
+ (slime-copy-presentation-at-point): Don't add face text property.
+ (slime-repl-grab-old-output): Likewise.
+
+2005-08-31 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (to-string): Handle errors during printing of objects.
+
+2005-08-30 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * slime.el (slime-mark-presentation-start/end-handler) modify
+ regexp to recognize negative presentation ids to make
+ presenting-object work with bridge mode.
+
+2005-08-30 Luke Gorrie <luke(a)synap.se>
+
+ * present.lisp: Added public domain dedication (OK'd by Alanr and
+ Matthias on the list).
+
+2005-08-29 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank-lispworks.lisp (env-internals:confirm-p): Use new function
+ y-or-n-p-in-emacs rather than eval-in-emacs.
+
+ * swank-cmucl.lisp (eval-in-emacs): Removed.
+ (send-to-emacs): New.
+ (pre-gc-hook, post-gc-hook): Use new protocol message
+ :background-message rather than eval-in-emacs.
+
+ * swank.lisp (dispatch-event, send-to-socket-io): Handle new
+ messages :y-or-n-p, :background-message.
+ (y-or-n-p-in-emacs): New function.
+
+ * slime.el (slime-dispatch-event): Handle new messages :y-or-n-p,
+ :background-message.
+ (slime-y-or-n-p): New.
+
+2005-08-29 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el (sldb-insert-condition) - Add tooltip for long
+ condition string which otherwise falls off the right of the screen
+ * swank.lisp (list-threads) - thread name might be a symbol - pass
+ the symbol name when that happens
+
+2005-08-29 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (make-weak-key-hash-table): Remove the
+ implementation; SBCL doesn't actually support weak hash-tables.
+
+2005-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-repl-kill-input): New command.
+ (slime-repl-mode-map): Bind it to C-c C-u, like in comint.
+ (slime-repl-easy-menu): Include it in the REPL menu.
+ (slime-repl-mode-hook): Show the SLIME menu in the REPL too.
+
+ * swank-backend.lisp (make-weak-key-hash-table)
+ (make-weak-value-hash-table): New interfaces.
+ * swank-cmucl.lisp (make-weak-key-hash-table): Implement it.
+ * swank-sbcl.lisp (make-weak-key-hash-table): Implement it.
+ * swank-openmcl.lisp (make-weak-key-hash-table)
+ (make-weak-value-hash-table): Implement it.
+
+ * swank.lisp (*object-to-presentation-id*)
+ (*presentation-id-to-object*): Use new functions
+ make-weak-key-hash-table, make-weak-value-hash-table.
+
+ * slime.el (slime-enable-evaluate-in-emacs): New variable.
+ (evaluate-in-emacs): Security improvement: If
+ slime-enable-evaluate-in-emacs is nil (the default), don't
+ evaluate forms sent by the Lisp.
+
+ * swank.lisp (send-to-socket-io): Handle :evaluate-in-emacs.
+
+2005-08-27 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-presentation-menu): When an object is no longer
+ recorded, remove text properties from the presentation.
+
+2005-08-15 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-openmcl.lisp (condition-source-position)
+ ccl::compiler-warning-stream-position is sometimes nil, so placate
+ this function by making it (or .. 0). Wrong but I don't have
+ enough time now to figure out what the right thing is.
+
+
+2005-08-24 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (fuzzy-find-matching-symbols): When completing the
+ string "package:" present a list of all the external symbols in
+ package (completing "package::" lists internal symbols as well).
+ (inspect-for-emacs standard-class): List all the slots in the
+ class (as per standard-object). The previous method of hard coding
+ the slots in the inspector's code made inspecting custom
+ meta-classes useless.
+
+2005-08-24 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank-sbcl.lisp (method-definitions): present qualifiers (if
+ any).
+
+2005-08-23 Taylor R. Campbell <campbell(a)bloodandcoffee.net>
+
+ * slime.el (slime-goto-location-position): Added a second regexp
+ for the :function-name case which matches "(def... ((function-name
+ ..." (with N opening parens preceding the function name). This is
+ to allow scheme48 style function names and definitions.
+
+2005-08-22 Wolfgang Jenkner <wjenkner(a)inode.at>
+
+ * swank-clisp.lisp (fspec-pathname): Cope with CVS CLISP's
+ (documentation symbol 'sys::file) returning a list. Return either
+ a list of start and end line positions or nil as second value.
+ (fspec-location): Use it. Also, if we have to guess the name of a
+ source file make sure that it actually exists.
+
+ (with-blocked-signals, call-without-interrupts): Don't add
+ :linux to *features* since this changes the return value of
+ unique-directory-name in swank-loader.lisp.
+ Comment out with-blocked-signals.
+
+ Update some comments at the top of the file.
+ State the licence in the same terms as slime.el does.
+
+2005-08-21 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * present.lisp (menu-choices-for-presentation-id): Check against
+ the gensym in *not-present* instead of :non-present.
+
+2005-08-20 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank-sbcl.lisp (preferred-communication-style): guard against
+ non-Linux non-linkage-table platforms (and assume that they won't
+ have dodgy threads) with #+linux.
+
+2005-08-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Enable nested presentations.
+
+ * slime.el (slime-presentation): Remove slots start-p, stop-p.
+ (slime-add-presentation-properties): Use a new text property
+ layout. Also add an overlay to enable nested highlighting.
+ (slime-remove-presentation-properties): New.
+ (slime-presentation-whole-p): Changed interface.
+ (slime-presentations-around-point): New.
+ (slime-same-presentation-p): Removed.
+ (slime-presentation-start-p, slime-presentation-stop-p): New.
+ (slime-presentation-start, slime-presentation-end): Changed to use
+ new text property layout.
+ (slime-presentation-bounds): New.
+ (slime-presentation-around-point): Reimplemented to handle nested
+ presentations.
+ (slime-for-each-presentation-in-region): New.
+ (slime-after-change-function): Use
+ slime-remove-presentation-properties and
+ slime-for-each-presentation-in-region.
+ (slime-copy-presentation-at-point): Complain if no presentation.
+ (slime-repl-insert-prompt): Don't put rear-nonsticky text property.
+ (slime-reify-old-output): Handle nested presentations.
+ (slime-repl-return): Use slime-presentation-around-or-before-point.
+
+ Enable reification of presentations in non-REPL buffers.
+
+ * slime.el (slime-buffer-substring-with-reified-output): New,
+ factored out from slime-repl-current-input.
+ (slime-repl-current-input): Use it here.
+ (slime-last-expression): Use it here.
+
+ (slime-add-presentation-properties): Add text properties
+ modification-hooks et al. to enable self-destruction of incomplete
+ or edited presentations in non-REPL buffers.
+
+2005-08-15 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el (slime-goto-location-position) fix so the :method locator
+ regexp so that it can find eql specializers, (setf foo) methods, and to
+ allow (a single) newline between arguments in the arglist.
+
+ * swank-openmcl.lisp (specializer-name) patch from Gary Byers and
+ Bryan O'Conner to fix complaint about certain classes slipping
+ through the etypecase
+
+2005-08-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-mark-presentation-end): Really remove the
+ presentation-start entry from the hash table.
+
+ Merge some code from present.lisp, removing code duplication.
+ Minor code clean-up.
+
+ * swank.lisp (*object-to-presentation-id*)
+ (*presentation-id-to-object*, clear-presentation-tables)
+ (*presentation-counter*, lookup-presented-object): Move here from
+ present.lisp.
+ (save-presented-object): Likewise. Assign negative numbers only,
+ so as not to clash with continuation ids.
+
+ * swank.lisp (*repl-results*): Removed.
+
+ * swank.lisp (get-repl-result, clear-repl-results): Use new
+ implementations from present.lisp.
+ (add-repl-result): Likewise, don't take the negative of the id.
+ (*last-repl-result-id*): New variable.
+ (clear-last-repl-result): Use it here.
+
+ * slime.el (slime-repl-insert-prompt): Don't take the negative of
+ the id.
+ (slime-presentation-expression): New, take care to handle
+ arbitrary *read-base* settings.
+ (reify-old-output): Use it here.
+ (slime-read-object): Use it here.
+
+2005-08-12 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (substring-no-properties): Fix to handle non-zero start
+ argument correctly.
+
+ Patch to remove use of the slime-repl-old-output text property in
+ favor of the slime-repl-presentation text property, in order to
+ simplify the code.
+
+ * slime.el (slime-presentation-whole-p): Generalize to work with
+ strings too.
+ (slime-presentation-start, slime-presentation-end): Likewise.
+ (slime-presentation-around-point): Likewise.
+ (slime-presentation-around-or-before-point): New.
+
+ * slime.el (reify-old-output): Use slime-repl-presentation
+ property and slime-presentation-around-point function rather than
+ slime-repl-old-output property.
+ (slime-repl-return): Use slime-repl-presentation rather than
+ slime-repl-old-output.
+ (slime-repl-grab-old-output): Use
+ slime-presentation-around-or-before-point.
+ (slime-read-object): Use slime-presentation-around-point.
+
+ * slime.el (toplevel): Don't handle slime-repl-old-output text
+ property.
+ (slime-add-presentation-properties): Likewise.
+ (slime-after-change-function): Likewise.
+
+2005-08-12 Yaroslav Kavenchuk <kavenchuk(a)jenty.by>
+
+ * swank-clisp.lisp (fspec-pathname): Use the documentation
+ function instead of accessing clisp internals.
+
+2005-08-11 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp (transpose-lists): Fixed it.
+
+2005-08-10 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el move slime-repl-add-to-input-history to
+ slime-repl-send-input so we can see the presentations we copied to
+ input when we reuse history rather than #.(blah...)
+ [Thanks Matthias! - was very busy and just returned to see your
+ changes merged. Most excellent.]
+
+2005-08-10 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-presentation-around-point): Change interface,
+ return presentation as primary return value.
+ (slime-copy-presentation-at-point): Use
+ slime-presentation-around-point. Copying now also works when the
+ first character is clicked and when the REPL buffer is not current.
+ (slime-presentation-menu): Use slime-presentation-around-point.
+
+2005-08-10 Martin Simmons <martin(a)lispworks.com>
+
+ * swank-lispworks.lisp (defadvice compile-file): Return all values
+ from the real compile-file.
+
+2005-08-10 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp (transpose-lists): Replaced with much nicer function
+ by Helmut Eller.
+
+2005-08-09 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-read-object): Handle ids that are conses.
+ Patch by "Thas" on #lisp.
+
+2005-08-09 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp (transpose-lists): Reimplemented without APPLY so we
+ don't have problems with CALL-ARGUMENTS-LIMIT.
+
+2005-08-08 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (undo-in-progress): Define for XEmacs compatibility.
+ Reported by Friedrich Dominicus.
+
+2005-08-07 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Fix for the presentations menu. Reported by Aleksandar Bakic.
+
+ * present.lisp (lookup-presented-object): Handle ids that are
+ conses.
+ (execute-menu-choice-for-presentation-id): Use equal for comparing
+ ids, to handle the cons case.
+ (menu-choices-for-presentation): Quote the presentation id, as it
+ can be a cons.
+ * slime.el (slime-presentation-menu, slime-presentation-menu)
+ (slime-inspect-presented-object): Quote the presentation id.
+
+2005-08-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (form-completion): New generic function, factored out
+ from complete-form.
+ (complete-form): Factor out form-completion.
+ (form-completion): Specialize on defmethod forms to insert arglist
+ of generic function.
+
+ * doc/slime.texi (Programming Helpers): Document C-c C-s,
+ slime-complete-form.
+
+2005-08-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Improvements to the presentations feature. Parts of presentations
+ can be copied reliably using all available Emacs facilities (not
+ just kill-ring-save), and they are no longer "semi-readonly" (in
+ the sense that keypresses are silently ignored). Whenever a user
+ attempts to edit a presentation, it now simply turns into plain
+ text (which is indicated by changing the face); this can be
+ undone. Presentations are now also supported if
+ *use-dedicated-output-stream* is nil. It is now possible to
+ access the individual values of multiple-value results. For some
+ systems (Allegro CL and upcoming CMUCL snapshots), presentations
+ can be reliably printed through pretty-printing streams.
+
+ * present.lisp (slime-stream-p) [allegro]: Allow printing
+ presentations through pretty printing streams.
+ [cmu]: Allow printing presentations through pretty printing
+ streams, if CMUCL has annotations support and we are using the
+ bridge-less protocol.
+ [sbcl]: Allow printing presentations through indenting streams.
+
+ * present.lisp (write-annotation): New function.
+ (presentation-record): New structure.
+ (presentation-start, presentation-end): New functions, supporting
+ both bridge protocol and bridge-less protocol.
+ (presenting-object-1): Use them here.
+
+ * present.lisp [sbcl, allegro]: Add printer hooks for unreadable
+ objects and pathnames.
+
+ * swank.lisp (*can-print-presentation*): New variable, moved here
+ from present.lisp.
+ * swank.lisp (interactive-eval, listener-eval, backtrace)
+ (swank-compiler, compile-file-for-emacs, load-file)
+ (init-inspector): Bind *can-print-presentation* to an appropriate
+ value.
+ * present.lisp: Remove code duplication with swank.lisp for the
+ functions above.
+
+ * swank.lisp (encode-message): Don't use the pretty printer for
+ printing the message length.
+
+ * slime.el (slime-dispatch-event): New events :presentation-start,
+ :presentation-end for bridge-less presentation markup.
+ * swank.lisp (dispatch-event, send-to-socket-io): Likewise.
+
+ * swank.lisp (listener-eval): Store the whole values-list with
+ add-repl-result.
+ * slime.el (slime-repl-insert-prompt): Accept a list of strings,
+ representing individual values of a multiple-value result. Mark
+ them up as separate presentations.
+ (reify-old-output): Support reifying individual values of a
+ multiple-value result.
+
+ * slime.el (slime-pre-command-hook): Don't call
+ slime-presentation-command-hook.
+ (slime-post-command-hook): Don't call
+ slime-presentation-post-command-hook.
+ (slime-presentation-command-hook): Removed.
+ (slime-presentation-post-command-hook): Removed.
+
+ * slime.el (slime-presentation-whole-p): New.
+ (slime-same-presentation-p): New.
+ (slime-presentation-start, slime-presentation-end): New.
+ (slime-presentation-around-point): New.
+ (slime-after-change-function): New.
+ (slime-setup-command-hooks): Install slime-after-change-function
+ as an after-change-function.
+
+ * slime.el (slime-repl-enable-presentations): Make
+ slime-repl-presentation nonsticky.
+ (slime-mark-presentation-start, slime-mark-presentation-end): New
+ functions.
+ (slime-mark-presentation-start-handler): Renamed from
+ slime-mark-presentation-start.
+ (slime-mark-presentation-end-handler): Renamed from
+ slime-mark-presentation-end.
+ (slime-presentation): New structure.
+ (slime-add-presentation-properties): New function.
+ (slime-insert-presentation): New function.
+
+2005-08-03 Zach Beane <xach(a)gwi.net>
+
+ * swank-sbcl.lisp (swank-compile-string): Restore honoring of
+ *trap-load-time-warnings*.
+
+2005-08-03 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp: Remove SBCL 0.9.1 support.
+ (swank-compile-string): Funcall the compiled function outside
+ with-compilation-hooks to prevent runtime warnings from
+ popping up a *compiler-notes* buffer.
+
+2005-07-29 Marco Baringer <mb(a)bese.it>
+
+ * doc/slime.texi (Other configurables): Document
+ *dedicated-output-stream-port*.
+
+ * swank.lisp (*dedicated-output-stream-port*): New variable.
+ (open-dedicated-output-stream): Open the stream on the port
+ *dedicated-output-stream-port*.
+
+ * slime.el (slime-set-default-directory): Fix typo in doc string.
+
+2005-07-26 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (inspect-for-emacs): Don't make whitespace
+ surrounding :action buttons part of the highlighted region.
+
+ * slime.el (slime-goto-location-buffer): Put "SLIME Source Form"
+ buffer into Lisp mode.
+
+2005-07-26 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (compile-file-for-emacs): Accept optional
+ external-format arg. I frogot to commit this file on 2005-07-05.
+
+ * slime.el (slime-input-complete-p): Skip over strings too.
+
+2005-07-26 Zach Beane <xach(a)xach.com>
+
+ * swank-sbcl.lisp (swank-compile-string): Revert to old string
+ compilation behavior to fix compiler note annotations. Code from
+ Juho Snellman.
+
+2005-07-24 Tom Pierce <tlpierce(a)gmail.com>
+
+ * swank.lisp (format-iso8601-time): New functions. Properly
+ formats a universal-time as an iso8601 string.
+ (inspect-for-emacs integer): Use the new
+ format-iso8601 function when printing an integer as a date.
+
+2005-07-22 Marco Baringer <mb(a)bese.it>
+
+ * swank-openmcl.lisp (frame-catch-tags): Remove some debugging
+ forms which were "polluting" the repl buffer when viewing an sldb
+ buffer.
+ (function-source-location): Make :error messages have the proper
+ form (exactly one string argument). This fix also removes the
+ issues with sending unreadble lists (containing #<...> to emacs).
+
+2005-07-14 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-allegro.lisp (find-external-format): Fix typo.
+
+2005-07-06 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-send-sigint): Use the symbol SIGINT stead of the
+ signal number. Suggested by Joerg Hoehle.
+ (slime-compile-file): XEmacs needs the buffer as argument to
+ local-variable-p. Reported by Andy Sloane.
+
+2005-07-05 Helmut Eller <heller(a)common-lisp.net>
+
+ The file variable slime-coding can now be used to specify the
+ coding system to use for C-c C-k. E.g., if the file contains
+ -*- slime-coding: utf-8-unix -*- Emacs will tell the Lisp side
+ to call COMPILE-FILE with an external-format argument.
+
+ * slime.el (slime-compile-file): Send the coding system if
+ the buffer local variable `slime-coding' is bound.
+
+ * swank-backend.lisp, swank-sbcl.lisp, swank-clisp.lisp,
+ swank-lispworks.lisp, swank-cmucl, swank-allegro.lisp,
+ swank-abcl.lisp, swank-corman.lisp
+ (swank-compile-file): New optional argument `external-format'.
+
+ * swank-clisp.lisp (getpid): Undo the last change.
+
+ * swank-corman.lisp (spawn, thread-alive-p): More thread tweaking.
+
+2005-07-03 Joerg Hoehle <hoehle(a)users.sourceforge.net>
+
+ * swank-clisp (describe-symbol-for-emacs): Report :setf and :type
+ where appropriate.
+
+2005-07-03 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (next-single-char-property-change)
+ (previous-single-char-property-change) [xemacs]: Only define them
+ if not present.
+ (next-char-property-change, previous-char-property-change): Define
+ if needed.
+
+ * README: Show examples for the filenames instead of the general
+ "/the/path/to/this/directory". Suggested by Brandon J. Van Every.
+
+ * swank-corman.lisp (default-directory): Return a namestring
+ instead of the pathname.
+ (inspect-for-emacs, inspect-structure): Teach the inspector how to
+ deal with structures.
+ (spawn, send, receive): Implement rudimentary threading support.
+ It's now possible to connect with the :spawn communication style
+ and to bring up a listener. Unfortunately, debugging the
+ non-primary threads doesn't work at all. Still no support for
+ interrupt-thread.
+
+ * slime.el (slime-start-swank-server): Send an extra newline
+ before the "(swank:start-server ...". I don't know why, but this
+ seems to fix the problem when starting CLISP/Win32. Interrupting
+ CLISP/W32 is still horribly broken.
+
+ * swank-loader.lisp (compile-files-if-needed-serially) [corman]:
+ force-output after each file.
+
+2005-07-02 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (save-some-lisp-buffers): New Function.
+ (slime-repl-only-save-lisp-buffers): New customizable variable.
+ (slime-repl-compile-and-load): Use save-some-lisp-buffers.
+ (slime-oos): Use save-some-lisp-buffers.
+
+2005-07-01 G�bor Melis <mega(a)hotpop.com>
+
+ * swank-sbcl.lisp (threaded stuff): make SBCL 0.9.2.9+ work while
+ retaining support for 0.9.2
+
+2005-06-28 G�bor Melis <mega(a)hotpop.com>
+
+ * swank-sbcl.lisp (threaded stuff): horrible hack to make threaded
+ SBCL 0.9.2 work. (also, Happy Birthday Christophe!)
+
+2005-06-21 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp (find-matching-packages): Also use nicknames.
+
+2005-06-13 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp (list-all-systems-in-central-registry): Delete
+ duplicates.
+
+ * swank-lispworks.lisp (unmangle-unfun): If you rename a package
+ you should rename it everywhere...
+
+2005-06-12 Alexey Dejneka <adejneka(a)comail.ru>
+
+ * slime.el (slime-with-xref-buffer): fix "pgk" typo.
+
+2005-06-12 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank.lisp (ed-in-emacs): allow strings as well as pathnames;
+ don't call emacs for things that the emacs editor doesn't know how
+ to deal with. Return T if we called emacs and NIL if not.
+
+ * slime.el (slime-ed): Change a listp to consp, so that NIL
+ arguments are correctly handled.
+
+2005-06-11 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * swank-sbcl.lisp: Patched for SBCL HEAD: utilize the new
+ :source-plist functionality; maintain compatibility with 0.9.1
+ till 0.9.2 is out. Removed cruft left over from previous
+ excercises in supporting both HEAD and latest release.
+
+ * doc/slime.texi: Document Slime as supporting the latest official
+ release of SBCL, as opposed to a specific version number which
+ would need to be updated monthly.
+
+2005-06-10 Helmut Eller <heller(a)common-lisp.net>
+
+ * nregex.lisp (slime-nregex): Rename package to avoid name clashes
+ with other version of this file.
+
+ * swank.lisp (compiled-regex): Use the new package name.
+
+ * slime.el (slime-with-xref-buffer): Gensym package too, to avoid
+ problems when switching to buffers with -*- package: ... -*- file
+ variables. From Antonio Menezes Leitao.
+ (slime-property-bounds): Use the prop argument instead of the
+ hardcoded 'slime-repl-old-output. From Andras Simon.
+
+2005-06-07 Espen Wiborg <espenhw(a)grumblesmurf.org>
+
+ * swank-corman.lisp: Convert to Unix line-endings.
+ (create-socket): Pass through the port argument unmodified,
+ gettting a random port if 0. Requires supporting change in
+ <ccl>/modules/sockets.lisp.
+ (inspect-for-emacs): defimplementation instead of defmethod.
+
+2005-06-06 Espen Wiborg <espenhw(a)grumblesmurf.org>
+
+ * doc/slime.texi, PROBLEMS: Added notes about CCL.
+
+2005-06-03 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-background-activities-enabled-p): Allow
+ background stuff in repl-mode buffers too.
+
+ * swank-cmucl.lisp (sis/misc): Return t for :interactive-p.
+
+2005-06-01 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-load-system, slime-oos): Fix bug related to file
+ locking. Don't bind the variable system-name. system-name is a
+ predefined Emacs variable and is used among other things for lock
+ filenames.
+
+2005-06-01 Joerg Hoehle <hoehle(a)users.sourceforge.net>
+
+ * swank-clisp (getpid): Updates for current CLISP versions. Use
+ defimplementation. Define always (slime needs it).
+
+2005-06-01 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-background-activities-enabled-p): Return nil
+ instead of signalling an error if there is a open but no default
+ connection.
+ (slime-current-connection): New helper function.
+ (slime-connection): Use it.
+ (slime-first-change-hook): Only run when
+ slime-background-activities-enabled-p.
+
+2005-06-01 Joerg Hoehle <hoehle(a)users.sourceforge.net>
+
+ * swank-cmucl.lisp, swank-sbcl.lisp, swank-clisp.lisp
+ (describe-symbol-for-emacs): Distinguish macro and special
+ operators from functions.
+
+ * slime.el (slime-print-apropos): Must keep in sync with above,
+ therefore added :macro and :special-operator properties.
+
+ * swank.lisp (present-symbol-before-p): Make it conform to its
+ specification -- sort first by package and then by symbol name.
+
+ * swank-clisp.lisp (describe-symbol-for-emacs): Report :alien-type
+ when the name is known as foreign type.
+
+2005-06-01 Espen Wiborg <espenhw(a)grumblesmurf.org>
+
+ * swank-loader.lisp: Redefine compile-files-if-needed-serially for
+ Corman Lisp to load everything from source.
+
+2005-05-27 Espen Wiborg <espenhw(a)grumblesmurf.org>
+
+ * swank-corman.lisp: New file, swank for Corman Lisp.
+
+ * swank.lisp (simple-announce-function): force-output after
+ announcing.
+ (symbol-external-p): Be extra paranoid about the symbol's package;
+ find-symbol barfs on a nil package in Corman Lisp.
+
+ * swank-loader.lisp: Add Corman Lisp support.
+
+2005-05-24 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el text-property-default-nonsticky not defined in
+ xemacs. oops.
+
+2005-05-24 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el meta-w now removes properties before insertion if you
+ cut just a portion of the presentation. Added xemacs
+ support. Enabled in xemacs.
+
+2005-05-23 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el slime-presentation-menu - use with-current-buffer, so
+ that menus work even if you are not in the buffer with the
+ presentation.
+
+ * present.lisp More menu items for pathnames. Remember last
+ slime-stream-p value. *can-print-presentation* t during
+ swank-compiler and during presentation menu action.
+
+2005-05-22 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * present.lisp. (slime-stream-p) check if a stream is destined for
+ output in a slime listener. (checks *connections* looks into pretty-print
+ streams in openmcl and cmucl)
+ Don't present unless (slime-stream-p stream).
+
+ Variable *enable-presenting-readable-objects* The only readable object
+ which is presented are pathnames (e.g. pathnames printed when loading
+ and *load-verbose* is t). Try the useful menu :)
+ More to come if this doesn't cause problems. (nil this if it does)
+
+ *can-print-presentation* t around compile-string-for-emacs,
+ load-file, interactive-eval.
+
+ In cmucl, use fwrappers to modify behaviour rather than redefinition.
+
+2005-05-22 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * present.lisp. mouse-3 now gives a menu for actions on the
+ presentation. See documentation in file for information about how
+ to define menus. Also, disable presentations in inspector. Initial bits
+ of dealing with the possibility of presenting readable objects.
+
+ * slime.el support menu. Xemacs users beware this uses x-popup-menu,
+ which may be fsf specific.
+
+2005-05-20 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * swank.lisp make repl output presentation work even if
+ present.lisp not loaded
+
+2005-05-20 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-repl-enable-presentations): Default is enabled
+ in GNU Emacs but disabled in XEmacs. Feature is not portable yet.
+ Brutally 80-column'ified alanr's latest changes :-)
+
+2005-05-20 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * bridge.el new file. from ilisp cvs distribution to collect
+ in-band messages using process filter mechanisms. One edit which
+ calls bridge-insert with process argument as well as output
+
+ * present.lisp new file. Enough code to do the following:
+ (swank::presenting-object object stream (print "This is really
+ object")). This makes the string "This is really object" behave
+ like old repl input for the object. Sample code for openmcl and
+ cmucl that hooks this into the printing of unreadable objects This
+ should be part of swank.lisp (and lisp specific files) but I am
+ too chicken to merge yet. For now you have to load this file
+ manually.
+
+ * slime.el changes to support above:
+ slime-repl-enable-presentations: customize to enable this stuff.
+ Default value t. Set to nil to turn it off.
+ slime-presentation-start-to-point: map object ids to the (point)
+ where they start to print out. slime-mark-presentation-start,
+ slime-mark-presentation-end. handlers for the bridge messages.
+ slime-open-stream-to-lisp: When enabled start the bridge and
+ define the handlers.
+
2005-05-19 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * slime.el slime-presentation-map
+
+2005-05-20 Luke Gorrie <luke(a)synap.se>
+
+ * swank.lisp (clear-repl-results): Fixed unbalanced parens. Thanks
+ Lawrence Mitchell.
+
+2005-05-19 Alan Ruttenberg <alanr-l(a)mumble.net>
+
* slime.el (slime-presentation-command-hook) new function for
nicer behaviour for presentations.
(slime-pre-command-hook) do slime-presentation-command-hook
@@ -87,6 +3174,7 @@
slime-complete-symbol* and slime-simple-complete-symbol.
2005-05-06 Alan Ruttenberg <alanr-l(a)mumble.net>
+
* swank-openmcl.lisp specializer-name didn't handle
structure-class which caused meta-. of methods specialized on
defstruct arguments to fail.
@@ -7686,3 +10774,8 @@
* Everything: imported slime-0.2 sources.
+;; Local Variables:
+;; coding: latin-1
+;; End:
+
+This file has been placed in the public domain.
Modified: trunk/thirdparty/emacs/slime/PROBLEMS
===================================================================
--- trunk/thirdparty/emacs/slime/PROBLEMS 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/PROBLEMS 2006-11-30 16:32:54 UTC (rev 2092)
@@ -11,6 +11,13 @@
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
@@ -21,8 +28,10 @@
** SBCL
-SBCL versions from 0.8.15 to 0.8.21 should work. Newer SBCL's may or
-may not work. Don't use multithreading with 2.4 kernels.
+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
@@ -56,17 +65,31 @@
you may have to start CLISP with "clisp -K full".
Under Windows, interrupting (with C-c C-b) doesn't work. Emacs sends
-a signal 2 (= SIGINT), but the signal is either ignored or CLISP exits
+a SIGINT signal, but the signal is either ignored or CLISP exits
immediately.
-The backtrace doesn't include frames for compiled functions. Changes
-to CLISP's C code are needed to fix this problem.
-Interpreted code is usually easer to debug.
+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.
Modified: trunk/thirdparty/emacs/slime/README
===================================================================
--- trunk/thirdparty/emacs/slime/README 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/README 2006-11-30 16:32:54 UTC (rev 2092)
@@ -10,9 +10,10 @@
Quick setup instructions
------------------------
- In Emacs Lisp:
+ Add this to your ~/.emacs file and fill in the appropriate filenames:
- (add-to-list 'load-path "/the/path/to/this/directory")
+ (add-to-list 'load-path "~/hacking/lisp/slime/") ; your SLIME directory
+ (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") ; your Lisp system
(require 'slime)
(slime-setup)
@@ -26,10 +27,8 @@
Licence.
----------------------------------------
- SLIME is free software. The source files are licensed separately for
- maximum compatibility with their host environment, for example
- slime.el is GPL and swank-cmucl.lisp is public domain. See the
- source files for more details.
+ SLIME is free software. All files, unless explicitly stated
+ otherwise, are public domain.
Contact.
----------------------------------------
Modified: trunk/thirdparty/emacs/slime/doc/Makefile
===================================================================
--- trunk/thirdparty/emacs/slime/doc/Makefile 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/doc/Makefile 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,3 +1,5 @@
+# This file has been placed in the public domain.
+#
# Where to put the info file(s). NB: the GNU Coding Standards (GCS)
# and the Filesystem Hierarchy Standard (FHS) differ on where info
# files belong. The GCS says /usr/local/info; the FHS says
@@ -12,24 +14,29 @@
# Info files generated here.
infofiles=slime.info
-all: slime.ps slime.info slime.pdf
+TEXI = slime.texi contributors.texi
-install: install-info
+all: slime.ps slime.info slime.html slime.pdf
-uninstall: uninstall-info
+slime.dvi: $(TEXI)
+ texi2dvi slime.texi
slime.ps: slime.dvi
dvips -o $@ $<
-slime.dvi: slime.texi contributors.texi
- texi2dvi slime.texi
+slime.info: $(TEXI)
+ makeinfo $<
-slime.pdf: slime.texi contributors.texi
+slime.html: $(TEXI)
+ texi2html $<
+
+slime.pdf: $(TEXI)
texi2pdf $<
-slime.info: slime.texi contributors.texi
- makeinfo $<
+install: install-info
+uninstall: uninstall-info
+
# Create contributors.texi, a texinfo table listing all known
# contributors of code.
#
@@ -48,7 +55,11 @@
sort -nr| \
sed -e 's/^[^A-Z]*//' | \
awk -f texinfo-tabulate.awk | \
- sed -e 's/\o370/@norsko{}/g' \
+ sed -e "s/\o341/@'a/g" | \
+ sed -e "s/\o355/@'{@dotless{i}}/g" | \
+ sed -e "s/\o351/@'e/g" | \
+ sed -e "s/\o361/@~n/g" | \
+ sed -e 's/\o370/@o{}/g' \
> $@
#.INTERMEDIATE: contributors.texi
@@ -94,3 +105,4 @@
rm -f slime.info
rm -f slime.pdf
rm -f slime.ps
+ rm -f slime.html
Added: trunk/thirdparty/emacs/slime/doc/slime-small.eps
===================================================================
--- trunk/thirdparty/emacs/slime/doc/slime-small.eps 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/doc/slime-small.eps 2006-11-30 16:32:54 UTC (rev 2092)
@@ -0,0 +1,995 @@
+%!PS-Adobe-3.0 EPSF-3.0
+%%Creator: GIMP PostScript file plugin V 1.17 by Peter Kirchgessner
+%%Title: slime-small.eps
+%%CreationDate: Tue Nov 14 18:44:25 2006
+%%DocumentData: Clean7Bit
+%%LanguageLevel: 2
+%%Pages: 1
+%%BoundingBox: 0 0 252 104
+%%EndComments
+%%BeginProlog
+% Use own dictionary to avoid conflicts
+10 dict begin
+%%EndProlog
+%%Page: 1 1
+% Translate for offset
+0 0 translate
+% Translate to begin of first scanline
+0 103.29540259080517 translate
+251.14960629921259 -103.29540259080517 scale
+% Image geometry
+248 102 8
+% Transformation matrix
+[ 248 0 0 102 0 0 ]
+% Strings to hold RGB-samples per scanline
+/rstr 248 string def
+/gstr 248 string def
+/bstr 248 string def
+{currentfile /ASCII85Decode filter /RunLengthDecode filter rstr readstring pop}
+{currentfile /ASCII85Decode filter /RunLengthDecode filter gstr readstring pop}
+{currentfile /ASCII85Decode filter /RunLengthDecode filter bstr readstring pop}
+true 3
+%%BeginData: 57552 ASCII Bytes
+colorimage
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcDnQp&=1TJ,~>
+JcDnQp&=1TJ,~>
+JcDnQp&=1TJ,~>
+JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~>
+JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~>
+JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~>
+^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~>
+^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~>
+^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~>
+_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=<e0hVR5Pj58P;ahkZtYGnAsUCF&u
+Xg>RRajSr)m.C/Qo)F4~>
+_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=<e0hVR5Pj58P;ahkZtYGnAsUCF&u
+Xg>RRajSr)m.C/Qo)F4~>
+_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=<e0hVR5Pj58P;ahkZtYGnAsUCF&u
+Xg>RRajSr)m.C/Qo)F4~>
+_>al?q!dM,hr<khq#'=Ts8E&tr;?HlqY^3lr;HTmrp0RjrquQ`naQ,CqYg!b$NBttna#E'me-GU
+p&>['q!?_R[B6U<\@8]>TW+a/a2[rL%+WD>YGn1p]$&prp\j^`J,~>
+_>al?q!dM,hr<khq#'=Ts8E&tr;?HlqY^3lr;HTmrp0RjrquQ`naQ,CqYg!b$NBttna#E'me-GU
+p&>['q!?_R[B6U<\@8]>SYMdk^:j@0%*ZE"VkT`^]$&prp\j^`J,~>
+_>al?q!dM,hr<khq#'=Ts8E&tr;?HlqY^3lr;HTmrp0RjrquQ`naQ,CqYg!b$NBttna#E'me-GU
+p&>['q!?_R[B6U<\@8]>V6mGObffhD%+WSI]!S?7]$&prp\j^`J,~>
+h>[WWrVZQgrV-NkqY^<ko`#?tp?:)F[BI!Uf')i*lMh(eqtTjUnF$;Brp0RM%di]RoCV_Lp\=R\
+qu$Elo)B*rq=<_'da6P&m.UALrs\o'o&\EB_8O^YmeHbTrs\o'mFAPViU?6RSZ0Nnmg%djUU8G5
+p\jaaJ,~>
+h>[WWrVZQgrV-NkqY^<ko`#?tp?:)F[BI!Uf')i*lMh(eqtTjUnF$;Brp0RM%di]RoCV_Lp\=R\
+qu$Elo)B*rq=<_'da6P&m.UALrs\o'o&\EB_8O^YmeHbTrs\o'mFAPNg$@t9Q_M(XlNc+VT=!#1
+p\jaaJ,~>
+h>[WWrVZQgrV-NkqY^<ko`#?tp?:)F[BI!Uf')i*lMh(eqtTjUnF$;Brp0RM%di]RoCV_Lp\=R\
+qu$Elo)B*rq=<_'da6P&m.UALrs\o'o&\EB_8O^YmeHbTrrrDumFAP[rlbJ^Vm=2*bQc%f[*e.4
+rUg,?~>
+i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>Us'pZTo*]]&><]WTQDp\jIY$N0Yek2"S6bK.`Erl4rX
+&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFYYH=n8d,t$!pAYX%qXE=XWP-?nW4LRHq>U0h%/ohS
+[aX<je^`UCkMY^W#he/'d]LsbqYp0fJ,~>
+i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>Us'pZTo'Ze=ZtZ`DC8p\jIY$N0Yek2"S6bK.`Erl4rX
+&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFYWMcZ'd,t$!pAYX%qXE=XVR4(PUUo%Cq>U0h%/ohS
+[`n%#kND*rlfmd!#jCO?bH'(YqYp0fJ,~>
+i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>UWspZTo0_>_X^_6_GNp\jIY$N0Yek2"S6bK.`Erl4rX
+&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFY\[SrTd,t$!pAYX%qXE=XXhr)uZ+ANQq>U0h%/ohS
+[`cFp[C*Zc_S#6C#e.Ieb-TO`qYp0fJ,~>
+ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=YujOr):jPR)inGDVQ#lOAYeA&,YUT+6j
+rMKRl&ZM@nU8Fur\%T]%dFmOFo_SR^rt#,*mFJYMn*93*d]1LSp\jjd&,YqR];b5Zi8F"CZIeRB
+rqZR'qsDY1lH-<4XLlTm]<(D##dM"dh:&pnpAO[aJ,~>
+ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=SolKIEplJ&AinGDVQ#lOAYeA&,YT;)+R
+&tu(iSt`*_Z+%Eab0eo%lh(&Qq#:m(qX)k@WpB$<mE;ENkkG&Mrt#"th7KHKlKRR#^9ZAZqu6Ek%
+/]G:VsNL&hr!DRj5K@^#iO\'l-$WrpAO[aJ,~>
+ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=kd^ULV[^W<b3nGDVQ$iK\\eA&,YXL#19
+Yl1d*YS+4IURn3WX0K.I_ogB[ip675rqQL(rqc$5[(=K"`5g$'bNS^!p\td$o%gpab.kU%a2YF:
+n,*+[rsekmc*tWnTq@sSXfJ=km@FTWVQdYS\`*8\p&BO~>
+jSp5!r:odDfu^e(TW#$4`5KX*VPBrn_U.-&nbE%]rr3Q/q<,T+jM8%%Z,#G4_<:Xnn,E[lpZKc$
+a7&Kap$)PFrpL<S_o0']WM$/ubMVgcrqZR)r:8UMa62!paj&Z!WmpM7q#:p(p>j&hlI!DZ]?TEJ
+]]&S_qYq$(q<,Q6i4G)-M3+3lOR.f0N0'^WmB"n/r:U)?~>
+jSoYfr:odDfu^e(SYE!prk&ZETV&$d_U.-&nbE%]rr3Q/q<,T#lJgaZi8X%._<:Xnn,E[lpZKc"
+^?b+Po^)SC%GA>*Yb%S[Vmjk,nG<.[rt#%ugU4c]kN(^cl.W)cn,)n[&H2=`_5$AZio/kXlE\(]
+pAOjf%K?1d^qT'lg=Os1gtUQLf*L$_h<"%&f(&\2s*t~>
+jSoYfr:odDfu^e(V6RMKrko5ZYH4P+_U.-&nbE%]rr3Q/q<,T1^SmiuTr>`A_<:Xnn,E[lpZKc*
+`luZIou$jQrQG\e`4`=ZUo1]FhsgLAq>V!'o%URl_R6MJYe%o[eF3;0rt,/&jMA1@ZDaXtYeRud
+iV*6Hrso&(kJ5*MVO*gCQ^<u(SF)jQS!TSJa0jLgr:U)?~>
+jo5bfq=3Rs^o=!Gi9omnrSSgZlL"&YYFr&9f&uZ$rr<#tp><.DeZ=^dN2tLtZ/>9Sn,E[jn'nDq
+i76B&ouR3]rm_J2i8E\]lL+,hXhEQ]r;-F*rqPZpWTqU,S"$+djLMq`p\t!g&GtqFVs_s0PE:m'
+dI*aUmeck\%0$%_\AdC<OF21uK7NrKs+:9-!/p]8re^Z,$@I,DJssdGY0lb:p&BO~>
+jo5bfq=3Rs^o<g:g$J(krTPHim-X,NVk(!.f&uZ$rr<#tp><.@kMOqDf\blXZ/>9Sn,E[jn'n>j
+l0%6kp#H,8roXCIl07L4liue!VnLpWr;-F*rqPZpU?psugt^`FlE\(_p\t!g#5dl<V!R7#rn7S5
+k3Sbfmeck\%0$%_\@h(bg="<qeC4EFs4%)#!8./%rn%2"$I[>KeD0-OVpY#3p&BO~>
+jo5bfq=3Rs^o=9Obf[l@rOa8f`5g*>\>6:Ff&uZ$rr<#tp><.![@`qYS"@%3Z/>9Sn,E[jn'nV`
+]X>/OorS5"rj<3E]Y)"t`6-<H\%UVgr;-F*rqPZpZc&u<Q^=/>^V@GAp\t!g&GtqFXNIi=QC!r.
+ZH9&lmeck\%0$%_\AZ%WQ`IKoUS[sjs.fUb!1WhPrgj(a$EL>7UR/+$\'a^Cp&BO~>
+kPl%kr:]F/_5=EomGQ[Fai+.i+Mc+De_oWYdBTXhhspRBs8DWFVsi0;M04ZUeaKEjp&4C[$3'b_
+^rPBFXK8,gRfK>bX:DMI]>2P1dFI(<^;T1/rql^-r:8L?i7YAoK7f#]eaK<anbi7`')q^i^q/UB
+PC(a)n.P/$(f]]Akequ7B0pYrX"i4G(uBk_L(Jr,SXR]EKoqRZ[,s-a:VNerU]aQg"Znbi([J,~>
+kPl%kr:]F/_5=0amHNisjQ$3t+QDJDkNV=!af25XhspRBs8DWFVsEO'f?`(+kNf&#p&4C[$3'b_
+^q]-mhr!8_g]641h[\T'iSrqZk3)!q[`%>'rql^-r:8L?g$%AHeC<+-kNeqonbi7`')q^i^p<7b
+g=+Kug>_D&]]Akequ7B0pYrWol/C@Eb0%rPeCWF0gu%#IqVhG2s4dt8g"4j2jQrnrnbi([J,~>
+kPl%kr:]F/_5=`da1SmeXfMDt+K2EH[CjB!agn@hhspRBs8DWFVp)Q@S@"iY[EPQ'p&4C[$3'b_
+^rO*bT:_SFQN3QTT+7QlVPpW!ZF.9^_o1^4rql^-r:8L?bdX:8USFBO[EPGsnbi7`')q^i^qd^`
+QDgj_QDhR4]]Akequ7B0pYrX!]V_$raiV93URdd=Q_'eBqPO7`s-F([R(a)Tn8Xi.d"nbi([J,~>
+kl21mqXW[jYG^=Ag!..6VONkLO<BaVTrblEdG=!DXM<]cr;Z`ffq\#dXGM(VX4?[6g%>74rsA]!
+iNr"'XGMdfon*7"reV,DOH>ZqS#39qeaKToo_n^f'E7jn`i87FRtGWtJssdGVoS*!rql^.rUo!M
+dG;6kH>.S]Z.\'7g%51>rtPJ-j0lna]9%DS>]54_X1HBne^`@Li;V:,a9oMeX/ii!jIG&urUp2@~>
+kl21mqXW[jYFsS7kiLd]hV?l`g)o,+hr3VXl0I$"^Ynb^s8DTCU[.+#f?`(+kNenro_n:Z$3'\X
+Zg6f3f@SRGe,\)!f)XJ&gAfq6hV[;Tl`Ak5rVZ[/rqbp"U?psreBH.dguRgqa6NO#qu7<-p"cgo
+l/C=Cb0\f!kh2rgoDSRd'`Rmf[_1k`g="-?bgbG*iT0(_kNMd,roa=Bs5F"8#3"t'QJM33p&BO~>
+kl21mqXW[jYHc<g\$2a'S<oN>QQVT\R\-IXZF[os[D1Ylr;Z`ffqZd!T:E9ZT!ce;g%>74rsA]!
+iNpb9T:DFFoqMMYrgXIfQ^=#)Q^j\C[EP`,o_n^f'E7jn`j3ObQ_V:/UR/+$YfH&*rql^.rUo!M
+ah"78Y0!r<Tsr7Fg%51>rtPJ-j0ln=VO+@*`4r(6Su/Wl[C*L?]`,>=XU:r#St;h"fsBN,rUp2@~>
+l2M=oqXE=XUVuHN`3H"tN/*%9rHo`:K8#/DQ);".g$5``lh^VZo[oo,eZ=UMM6#1qU=f,:nG`am
+pY`=FeZ=W(K)0BuF*2bUG^OmfK7er9R`Octe+*A6rtGA)i3^G\]9%DSBRGoQi5E+ap\t'i')_:K
+TC:=3M03<JKqQ]XUWr6(qu7W7puK!)i4G(uBlATlaOT56lL43!_SEt)_na(en,MY[i8)r6i9cK,
+lM:GPs*t~>
+l2M=oqXE=XTtKaUj5AbIf[eR$rR)h;eCE1)gYUoLkj57klh^VZo[oo(kMOn;fAGcWU=f,:nG`am
+pY`=BkMOnfeG@B%cHjndd*g@keC<($guRh$e+*A6rtGA)i3^/]iS)`&ajSo%l+FLbp\t'i')_:K
+TBk[tf?_"Pe_T?ST?Zg$qu7W7puJuul/C@Eb08AjjQGdom-Euj]!f)[]=,0Ili6;Yl0.<nl0Wu"
+lM:GPs*t~>
+l2M=oqXE=XWPl`aX.buKS"?COrMq'>US43EQ(4VM\&>c!lh^VZo[on^[@`trSY!75U=f,:nG`am
+pY`=#[@`ucU\_\;\$W<=Z)aq(USFENQ`\3:e+*A6rtGA)i3^G8VO+@*b,^o,]Yh5<p\t'i')_:K
+T?O^8S@$>KTpi4+XNg21qu79-puK!(]V_$rahOU;XgPg[`;[sb_8jX6_T0^rbl>Tg]XkMY]Z7S&
+lM:GPs*t~>
+lMhLrq<ltJU#+_LZ'C9%I!BpeJqs>^+GGDrH$k-tNg6m"n%.TTrr)KAU@6X6M04ZUeaK6bo_n:Z
+#QFM[][>QDT_b)XJoCQl!b$#!r/(B(#,]f9YL;q<r;RH.n^X?%eZ=UM(a)q9eAZ.\'6g%>7?rtG7p
+aJ\=FRtGWaCk.ehkH;Ybq>U<l.fT8,^8^;6Q%3e)R`Od-_ip@!CNQauDmZliDJX'$Q(l+An*e,M
+I_bURo`'F~>
+lMhLrq<ltJSD*5gi7lo7da6CjeCOWN+P"uidF-Lpg"YHJlal0Prr)KAU?h""f?`(+kNekpo_n:Z
+#QFM[]ZKEsh>5n-eBIif!jg,#r7Cns#2\M/WRC;6r;RH.n^X?!kMOn;\\?GCi98jmg%>7?rtG7p
+aJ%t]gsjQFbL>5+l__M^q>U<l.fT8,^7X`OgXFBrguRh/]7l#@=_+^A?F7(F>Zt61LRbiolg)'+
+DS#K<o`'F~>
+lMhLrq<ltJWQ2ZRTp;+@X0Jh)US%OV+JGR/Y,eCjR?aJRbdum1rr)KAU<L$;S@"iY[EPAto_n:Z
+#QFM[]Zds^Rei?OUV?ZF!li!Mr13e]#+W!(a)]$g*Gr;RH.n^X>W[@`tra2kNTTsr7Eg%>7?rtG7p
+aK`[cQ_V:6_PWU!_RIAFq>U<l(]O6n^:M1^Q)26jQ`\3B_RmL`Yd(C=[JmNDZa$a:]rT5tbfn2@
+]@Z]Qo`'F~>
+li.Xtq<lnDVsVmDRuDlBF+/n$Q("TLX!"((P)bBSJqBZ,i:488p\t-`fV7ibXGM(VX4?[5f_#.2
+rs&>ecA:l@c2,KfRt>Q`91rN.JsuV<rL*qfdI*[[oDSUe'Dh%9W9VKoK5Y"&F,-X?m[qkpr;?R/
+rqPQc\E(GhIVW)"I#tqt_mSLurqudGrqblrS*J+bK7]Q5lAK2SF*;eSL>RB+iSf03H[9p[_/X@p
+DfU)Zc27M4s*t~>
+li.Xtq<lnDT^Cn#gt:*&cI1:qgYCZbh]Ub1g=b*/eC<=5l0>_:p\t-`fV7]phq-3+hrj="f_#.2
+rs&>ec?\g(a)jne$EgsjQEBP=6deD0uZrS.V6k3SPhoDSUe'Dh%9U?psreBFepcIUk7m$uGkr;?R/
+rqPQcYNk-$e'"0$db<[E]X?bnrqudGrqblrOmM/aeC<:7m!_j6@:Wt`G2I%MiSeNdBkV*h_-^HL
+?!q8ia8>l.s*t~>
+li.Xtq<lnDYfF&HQ^ahV\>Z$jQ'\$?SfjJgQC4;9USF9T][XCLp\t-`fV6TtT:E9ZT!ce:f_#.2
+rs&>ecF_-+YkkI.Q_V:5]tMA!UR1nMrKd_YZH9E)oDSUe'Dh%9Z,Ec2UV=^e\=]:saeR5Or;?R/
+rqPQc]t^M3W5ZZsX-fcs_mSLurqudGrqblr[)B)5USF0X`3cMF\@]Gh_r&;IiShVh^q[Rp_7$_Q
+[(!`gjSSrKs*t~>
+m/Ie!qXE4IV<Z=&OFqdrIYWcWX2N*,rm`.9aM50aVOEsH]'dSQk5##To[oo,eZ=UMM6#1qU=f,:
+n,EUjp#:(\iU-L,$-AZgDd6OcJssdYec!PndFH75jS/ZPrtYP.jh&%`^ls4_=^5lsR`Ocj`9R3u
+rVmT1p"Z[sh6r>iB2rJdMm:snWnd:Gqu7Q1lG]=Zad[p7R`OcVDUX#aJV&sWK7ipmKDpH1JUls4
+I,97"J<87ZoDa=~>
+m/Ie!qXE4ITBt[rg=4Kndam%,hrEe[roYEcjPo.UhV?oBiU".jk5##To[oo(kMOn;fAGcWU=f,:
+n,EUjp#9G<g?nb'$09mkbbh5\eD0-_kPaHGk3'LOjS/ZPrtYP.jh%_]inDl)RAJ-WguRgo`9R3u
+rVmT1p"Z[ll/C=C`JhOXf\kuHWnd:Gqu8)@lG\tRjP887guRgS>gmJ+DfC7$EH1aIEH,r:Df4cS
+C>N]ADLg"2oDa=~>
+m/Ie!qXE4IYJdZ8Q_Uh#W1TWNSu]!!rj<lQXf/"dS<oS2VTI6#k5##To[on^[@`trSY!75U=f,:
+n,EUjp#<NtbfBRu$*BPh^;Rt)UR/+\[Jd33ZF.Q_jS/ZPrtYP.jh&4@W0XC$_o0<bQ`\3/`9R3u
+rVmT1p"Z[k\tb[rahc''S"[=8Wnd:Gqu8)@lG^0LXd>fXQ`\3:ZdZe1`lH?uaN4,MaN2EB`l7/Y
+_;<#G`Qd]IoDa=~>
+m/IdtoA@0XlH,`THuEqGM5I?$e`Z5crpLuslK$dOdE'DRea@b2med"^o[oo,eZ=UMM6#1qU=f,:
+n,F7(qso,XGH%U-Pbt7>Q)D`nK5Y[[R`NR_rU9^M"n&Y&\FBCnrtYM*hQG8^[Z5ZH<E<d\OLjAg
+\`EPbrVmT0n^F)ueZ=UM@o6]XM6#1qT[iW3qu73'lc,L\ad[p7R`OcYF6%rPKE[S=Kn]O*re:?)
+#l91+p4J!NP1K4(J,~>
+m/IdtoA@0Qm,[!Rd`fq]fA>EIkNhL$rp(]om-<ftk2bUbkNlp1med"^o[oo(kMOn;fAGcWU=f,:
+n,F7(qsnN5B;D;XL7b&iO.YLgeBH.dguQG\rTjCJ"K/W4nGE.`(&dg^Y0-"fg!RctOic&*iT\"c
+jS8`QrtPD$e"5mghq-2bI^m_Uhrj<ueai\9rttUu`focMgsjj/jQqS/jD]-[F+aI5F8l1;F8p7d
+qJgNKEH-#Od.73e~>
+m/IdtoA@0a`3#K"X1l?USXc:W[DKl(rlcM*`4rmkZE:75[E5l)med"^o[on^[@`trSY!75U=f,:
+n,F7(qsqV9['?sN]W\HKT!b\eUV=L<Q`\!;rQP5Y"j+Tfd.$r1rtYM*hQFu3URA:,_8=?qR&7O7
+\`EPbrVmT0n^F)R[@`tra1o[%SY!75T[iW3qu7N0lc-BOXd>fXQ`\3<\E(]Pai`!0b0'__rQ>/^
+#l;W`p;k=sd-^E(J,~>
+mJf3GpufYlmEM>YF(oQ8M6#%Sma%ntS"+2]Kp9'nn*]K+mGF7PjS&QPrUea:n("LrFc!0Ln"SJ,
+rU0\3rqh:sLXXIiFiM79Q&Y(NRtH<]aQe[mBPM7MQBd`$HZRi\q>U<l(&d^SU@6X6M03<*<+^E9
+[b]?6hY-sIrtP=qa/A4ERtGWa9jVgnTZukucL:Z-rt"tl`guD:RtH<]aQf"3l(a)f.j"dAt?L&_2M
+K`h@/L&V(*!L)+*s*t~>
+mJe4+pufYhmH*0ScH=AWfAG`Rm)YrVR@I?IG(m-?li-5fmFmD,jS&QPrUea:lf[0Wce%(;l_<&(
+rU0\3rqgYOGLOcGA&c>kQ%//]gsjj/jQq=l<`iImLkgbBC15c3q>U<l(&d^SU?h""f?_!VMT!oq
+iTSCdhY-sIrtP=qa.Ve[gsjQFDQD%4h<"$qcL:Z-rt"tl`focMgsjj/jQqV2l>llF"bZhrF8u:;
+Es)G`F8l/[!JAbis*t~>
+mJf3GpufYta0;#+\&lClSY!-paiCa#Tq&9S\@]DsbfRfAa3)0.jS&QPrUea:bdF(5[%3erbbEb^
+rU0\3rqjaS`7)rA]#MRoQ*nQ4Q_U=BXi.TFXfnps^:h4p\%()Kq>U<l(&d^SU<L$;S@$>O_9&jJ
+UUnOLhY-sIrtP=qa0ERbQ_V:6]u@UWR]si4cL:Z-rt"tl`jWgfQ_U=BXi.l`lH0%J"jm:lb5_M=
+aoh[db5VC_!RU6)s*t~>
+mJf3DnC=Jqfs-K\AT)sQX4?XAG&4^3cI7'eG'(<5CNukFWNp\qoDARfrUea:n("LrFc!0Ln"SJ,
+rU'V0re,obna:pXlK*8mYiNT`IY+$0lB,q,H$Rh^G'8(UIdkeaqu7E.m`hKnc(Ti2?VO@+Fc!0L
+n"\M+rVlg3rqGKa\E(GhIVW(Z>]54_aQfYBlh^MY&,PV3Sa+=dK7]Q5lBHGWK`6Z/PQ->js8VtM
+"94(/s8I]QPLf=)J,~>
+mJf3DnC=Jjkht+?^Wb-Xhrj@&AQlWScI6FSAR`5U=_FOdV6XWIoDARfrUea:lf[0Wce%(;l_<&(
+rU'V0rc<(0na::4lK)Z\V<['oe(!16m"8PRB4oY(A7T7bD",[Iqu7E.m`h?jjk\J3XDiQsce%(;
+l_E)'rVlg3rqGKaYNk-$e'".kV9IHEjQrPZlh^MY&,PV3PO.AceC<:7m"T$9ErL+`KE$"6s8Vt;
+"93F`s8I'?K@'2hJ,~>
+mJf3DnC=J]\"T:raM4dHT!c\TZ*LpOcI9MU]XbV[YdCdOZ*M!YoDARfrUea:bdF(5[%3erbbEb^
+rU'V0rlW=,na=B8lK,a^`4r7:W2#]]`4<4d^:r%.]=Y_j_slphqu7E.m`hfQYaV8s`P0+-[%3er
+bbNe]rVlg3rqGKa]t^M3W5ZZe`4r(6Xi.E_lh^MY&,PV3[`#;7USF0X`4W\Iao9Edd/V82s8Vu=
+"96Nds8L.Ad-^E(J,~>
+mf,?IpZ9/nkJWX9D/Xf`X4=@sDfpBeJ+)r[nUQ,NI!U%_GLYK!K)>QIs8DTBU@6X6M04ZUeaK6b
+o_n.Vs+M8Pr;2/#q=B!@_;MqeI"e6<m?D^@JV!@iJ-1CUqpkTD(B40p_klY?RtGWa928l9LSiJe
+S^6d&rr3c4o\-=lh6r>iB2qN,Ck.ehkH)G]q>U<l&,PV3Sa+=dK7]Q5lBHGWK`6Z/PQ->js8VtM
+"94(/s8I]QPLf=)J,~>
+mf,?IpZ9/glf6aKbfnMhhrgeI?"@X0D=@%7nSW4*C1q5)A^oRRE;TY7s8DTBU?h""f?`(+kNekp
+o_n.Vs)T97r;1MTq=A@.\*;l*dad18m=o(cDf>/aDJjB3EVn)ZrtbV1l,0+ZjP88/VJ(+WcIUk7
+m$c8hr;Q^3rUegDam%d;dD_&OT$,U;j6NPVkP>,Trt"tl`focMgsjj/jQqV2lZ2uG"bZhrF8u:;
+Es)G`F8u5\!JAbis*t~>
+mf,?IpZ90"_Q/ru_S<.=T!c;<[(F*6`:*9;n\rH._8!\/][YfVa8>l9s8DTBU<L$;S@"iY[EPAt
+o_n.Vs2lG1r;4UXq=DG0aLnC:X.buda1]%#`l@Pg`Poj;aSYB%rtbV1l,0[BXd>fs`P'"*\=]:s
+aeI,Mr;Q^3rUegDah"78Y0"Mm_nr:9X2;9ZkP>,Trt"tl`jWgfQ_U=BXi.l`lcK.K"jm:lb5_M=
+aoh[db5_I`!RU6)s*t~>
+mf+X3o%0etfs-K\Dg[YXeW=TiH[gYBK`(e%r.KauJqARBJFW;bK`:uN&H27RU@6X6M04ZUeaK6b
+o_n.Vs+M8Qs8Re,rqCiK_;MqeI"e6<m=oh8KS9:$KE?l-f),I_rqPQb`Se@iHtcYO93cCeR`Ock
+`p<L#rtbM#c_'XQVMB5$:IS;tI#tqt`4+e%rqud,qWc%jlH,NJJssdGP]c;Fre1N>s+Q1,s8.KP
+s+Q1,re1B:f(/ik~>
+mf+X3o%0emkht+?bgP5(kCZrJBl.haEr>lWr,QiQEH#jbDt3L?F8l1=&H27RU?h""f?`(+kNekp
+o_n.Vs)T!/s8R.]rqC39\*;l*dad18m<<,ZEcV*VErU1]s3UZC(B4*i\\.1cg="-,;J)cLeD0-O
+T>p3nrr3c2n'@Njk2+\7ZZf6.ajSo%l+FLcq#:3k&,PS1PO.AceC<:7m"T$9ErL+`KE$"6s8Vt;
+"93F`s8I'?K@'2hJ,~>
+mf+X3o%0e`\"T:r^T3a![C*<O^r4:gao)+[r5m(UaN)<h`pr`Cb5VD?&H27RU<L$;S@"iY[EPAt
+o_n.Vs2l/)s8U6arqF:;aLnC:X.buda18k%aiXJZaoBKas6]^`(B4*i\\u.XQ`J6F]"GtrUR/+$
+YK#o)rr3c2n'@fPZCIMq`kK%$b,^o,]Yh5=q#:3k&,PS1[D]26USF0X`4W\Iao9Edd/V82s8Vu=
+"96Nds8L.Ad-^E(J,~>
+mf+U0lc?'jad[p$I#tqtNbs#iJqSgVL&_1,s+Q1,KnP-WK`(h'L&M#_rUea:n("LrFc!0Ln"SJ,
+rTsRaKbosQs+Q1+pO'9_i4G(uM6#1qBR#)]L&_%(!WUaJs"OHGhQOiT]9%DS=%5\^C4;>\jLDnc
+q>UEnq<,SskJWX9D-KS#<bQlB]&:H/htI'Jrt,2+l,0%Vad[p7R`OcYFmF_[Ka!\?Kn]R,qh5.P
+Kn]R+K`RCgo)F4~>
+mf+U0lc>gejP88/db<[EJQl`&E,p%!F8u8]s)W8]F)uC"Er>oXF8c+MrUea:lf[0Wce%(;l_<&(
+rTsRaEu0K/s)W8\pM7(Cl/C@EfAGcW<bH>kF8u,Y!WUODs"OHGhQONTiS)`&P#>DLbL5,(lEIta
+q>UEnq<,Sllf6aKbb&<?Oic&*iT[qWhtI'Jrt,2+l,/\NjP887guRgVA*\17Es73rF*%B]qf;l>
+F*%B\Ergp?o)F4~>
+mf+U0lc?BMXd>fsX-fcsZa.9^a2uL'b5_Las2rLab0%j(ao).\b5M>OrUea:bdF(5[%3erbbEb^
+rTsRaaqrG)s2rL`pVO5W]V_$rSY!75Y.hotb5_@]!WVQas"OHGhQOf/VO+@*_Rd@s`i,3%^V.>C
+q>UEnq<,T'_Q/ru_Sj*u_TJpHVS'aKhtI'Jrt,2+l,0pIXd>fXQ`\3=]'IK;ap$/lb0'baqoT$@
+b0'b`aoTlVo)F4~>
+n,FF-puK!)i4G(uI#tqtcXh3IJqSf2s+ULQL&Zj\s8I]Us+ULQKn]L*&H27RU$pO5M04ZUeaK6b
+o_n.Vs+M8Qs8Re,rq:`C^u2hdI#4oSmqI'!KSBI'K`V5)qu8AKo@Tl-eZ=UM@o5Z`<bQlB]&:K4
+i:m6NrUo'Q_r/.gHtcYO78RH9M6#1qVqUeArVmH.q<,M^lH,NJJssdGP]c;Fre1N>re6()rV_EL
+K*_7)KDU=UKp1*Ys*t~>
+n,FF-puJuul/C@Edb<[E`Dg;_E,p#@s)\5?F8p<&s8I'Cs)\5?F*%<[&H27RU$Ln!f?`(+kNekp
+o_n.Vs)T!/s8R.]rq:*1[cuc)db!C>lW@e=F*%BYErl<fqu8AKo@Tl)kMOn;\UHe?Oic&*iT[t\
+i:m6NrUo'Q]BS;.d`R_N:jfe!fAGcWVqUeArVmH.q<,MSm,ZsOeD0-OL1BOirc86qrc</ZrV^d:
+E<GuUEVo`V!JAbis*t~>
+n,FF-puK!(]V_$rX-fcsbH&1ka2uKHs2tBAb5]W,s8L.Es2tBAb0'\_&H27RU!0p:S@"iY[EPAt
+o_n.Vs2l/)s8U6arq=13aLnC:X.>iibceb$b0'b]aoVP0qu8AKo@Tk_[@`tra1o*p_TJpHVS'dP
+i:m6NrUo'Q_n;k5X3&5i]"c:mSY!75VqUeArVmH.q<,N!`3#B$UR/+$]XmFNrlPDkrlWC^rVak<
+a924YaSYtZ!RU6)s*t~>
+n,FF-p>2t1fs-K\I#tqt^1MM:JqJ`0qh4nGK`6[Zs8I]Us+ULQKn]L*&H24OTC:=3M04ZUeaK9d
+o_n.Vs+M8Qs8Re,rq1W<i7YAoG_rKOmqR0#KSBI'K`V5)qu8AJn'@TndAD\?@8BKa;Ik!0Z.\'6
+g@Y@Dr:/7.n("LrF^n9A78RH9M6#1qT%*?/rVn;FpuT-,i4G(uJssdGP]Z)?K7nl=pO\"ho7;FB
+Isuk,I=CR8K7oH>o)F4~>
+n,FF-p>2t*kht+?db<[EZrCOOE,fo=qf;W5F8g6%s8I'Cs)\5?F*%<[&H24OTBk[tf?`(+kNenr
+o_n.Vs)T!/s8R.]rq1!*f]_8Gd+@1<lW@h>F*%BYErl<fqu8AJn'@Kik2+\7ZZeT0K>,^bi98jm
+g@Y@Dr:/7.lf[0WcaeL::jfe!fAGcWT%*?/rVn;FpuT-$l/C@EeD0-OL19=cEH6&MpMk0Eo5AMa
+D/=%KCM`BWEH?cZo)F4~>
+n,FF-p>2sr\"T:rX-fcs`N6Yga2lBEqoSd7b5TQ+s8L.Es2tBAb0'\_&H24OT?O^8S@"iY[EPE!
+o_n.Vs2l/)s8U6arq4(,bdX:8Z(7Jobcee%b0'b]aoVP0qu8AJn'@cOZCIMq`kJmm^rWdMTsr7E
+g@Y@Dr:/7.bdF(5[)]qo]"c:mSY!75T%*?/rVn;FpuT-,]V_$rUR/+$]Xd4HaN;NKpW1DIo>\bg
+`5BLQ_Sbc]aNDlso)F4~>
+n,FF,p"QG6eZ=UMF,-X?h/I4SH[^Hom""TrK(X_Jq>Q$Nre:CPKn]L*&H)(IS+"n/M04`]g$klm
+p&47Ws+M8Qs8Re,rUkK6n("LrFc!0LmqR0#KSBI'K`V5)qu8AHlc,jfad[p$>Y@sb:h"R(X4?[/
+ddd87qWc%tlH,NJDd5q3787*.KqQ]XU!<$&rVn;FpuAj%i4G(uJssdGPB#B,It)p(iSJq6eTc7[
+FE2B2EHB?NItIULo)F4~>
+n,Fa5p"QG2kMOn;cIUk7fO.rqBl%X'lu)=`E:n3jq/ULsrcA,>F*%<[&H)(IS*T7pf?`+-kj,,"
+p&47Ws)T!/s8R.]rUjm%lf[0Wce%(;lW@h>F*%BYErl<fqu8AHlc,UajP88/VJ&%nI(7MShrj<q
+ddd87qWc%mm,ZsObbf'$:i<>Ye_T?SS^$U"rVmE-puAirl/C@EeD0-OKj`^8D&$l4iSJ;$eRi?%
+@UWWR?X_/mD/oL#o)F4~>
+n,Fa5p"QFh[@`tr\=]:s`iQMZ^r++/m)AJba7[Npq8pb$rlY9@b0'\_&H)(IS'8:4S@"cZ\'Lr*
+p&47Ws2l/)s8U6arUmt'bdF(5[%3erbcnk&b0'b]aoVP0qu8AHlc-0IXd>fs`P&[k^W3^PT!ce4
+ddd87qWc&(`3#B$^;[e#]"Q(pTpi4+Wm0u/rVmE-puAj%]V_$rUR/+$]=6Sp`"g20iSMB&e\/T+
+\[])X[^aPs`5qlDo)F4~>
+n,Fa5p"QG6eZ=UMA93O'dG9@fDK9iAaEGnYHJ*XmjaVi5q1S_HKn]L*&H)"BU[?="Km\uni8L]k
+p&=:W(kn1Rs+Q1*oQm;$eZ=UMM6#1qC3kJbL&_%(!WUaKs"XNJk.J4b^ls4_=[u+a93cCeR`Ocm
+amAm&p>NEti4G(uBiePK<_H\9JssdGUr;QprVn;FpYrU!i4G(uJssdGOD;JJFE;K4Z`\,>Sp-Kc
+Pc_pC_T/`rGCK;:o)F4~>
+n,Fa5p"QG2kMOn;^<Y<dk1O`U>[V#NaCNWGB\@*7j_\pTq/ZH6F*%<[&H)"BTC(are^E11l.N)l
+p&=:W(it?0s)W8[oOt#ckMOn;fAGcW=D2YpF8u,Y!WUOEs"XNJk.Iq`inDl)R9F2aAu3`$guRgr
+amAm&p>NEll/C@Eb*&U2O_1H6eD0-OT#BpjrVn;FpYrTml/C@EeD0-OJQTV)@prcTZ`[K,SnEk6
+L8DPq\%\_FASq1fo)F4~>
+n,Fa5p"QFh[@`traL@e3ZH';S[(!TWaLfdI^Y-E=ji#0Zq8rU8b0'\_&H)"BX2hH5TrXQX][3\6
+p&=:W(s:5*s2rL_oY70F[@`trSY!75YeS6$b5_@]!WVQbs"XNJk.JCBW0XC$_n3Rh]YqR[Q`\33
+amAm&p>NEt]V_$rahl!:_S!h%UR/+$Y/KW%rVn;FpYrTu]V_$rUR/+$\$3Qb]"#5ZZ`^U/T!Z5F
+]X>\rai:`q]YsR2o)F4~>
+n,Fa6p>2t@eZ=UM@pjA5VU=eg_3:+KVj4$IC8Gcc]6/@Fk(*1&Kn]L*&Gtk;WTqTpK7&cli5)VS
+pAXCX(kn1Rs+Q1*oQm8#eZ=UMM6#1qC3kJbL&_%(!WUaKs"aTIi3L8Y]9%DS=%c@_8Qoq\Q,Mje
+^ZYCho%'Vpfs-K\AR&nkBNA5MIZhJ,\%Lhtrr2p5rqGBY`8J7hI"Ig.lAAo;Vj*CN`5KOlmf;eT
+l2^#Gi!/K*H[+r+rq$/?~>
+n,Fa6p>2t<kMOn;\['N3hWF4X[Y0BiTST51=J]5-]45Gek&9tjF*%<[&Gtk;U?psreC*(0l*mkR
+pAXCX(it?0s)W8[oOsubkMOn;fAGcW=D2YpF8u,Y!WUOEs"aTIi3KuZiS)`&P%K)R?_5HigZ.Ur
+^ZYCho%'Vikht+?^ST&uacVt6db<^GYIrulrr2p5rqGBY]BS;.da[(5m!MKmTSA/t]XtcSli$/M
+li$&Pm+H,cmEGS$s*t~>
+n,Fa6p>2sr[@`tra2YT\S?g2ZaLf*uZ+d9/YGJP3]=P\kk/R,lb0'\_&Gtk;Zc&u4UT9cZ]Z%)3
+pAXCX(s:5*s2rL_oY7-E[@`trSY!75YeS6$b5_@]!WVQbs"aTIi3L85VO+@*_S!Xr]YhU`Q)hd0
+^ZYCho%'V[\"T:raMc6.b/2'9W0XBs]tEJ%rr2p5rqGBY_n;k5X.u#``3Q/5Z+[ch`5BIkbQ,fb
+_uR[Q]EZ=!\@q:orq$/?~>
+n,F"!puK'(i4G(uBjP1gLSi>Li;Dj?mJZJ]_8V[aD81>TmXp2lrr3Q+m)Z*iad[p1OLjAdZJbKV
+lMhZas8Re,rUbE1n("LrFc!0LmqR0#KSBI'K`V5)r;SPNo@Tqufs-K\AQW2H>YA+2I#tqt_mA:p
+q!6%omEM>YEF3C,M0ru;BRGoQi5;n[p\t0l&,u=]ZGYV4OF1tuS&ssamJcANjSn*:eH""raT09X
+]*?C5d;e*jrU^&>~>
+n,F"!puK&rl/C@Eb,_hnf&#NPl29lJmJZ>Y[_7E.>ean1mW!:Hrr3Q+m)YjdjP885g>V;+ZJbKV
+lMhZQs8R.]rUactlf[0Wce%(;lW@h>F*%BYErl<fr;SPNo(a)Tqnkht+?^R1k-V.Yq4db<[E]<gGh
+q!6%kmH*0Sc)f%8f@%d'ajSo%l+=:\p\t0l&,u=]ZFfA[g="3pguRhfmJcGPlMg&Ik5aZDj8e6=
+i<JB,aC!lIrU^&>~>
+n,F"!puK'/]V_$rai29/T:E-p]_o\Ja8O3iaMkj"ZbO35m`<NLrr3Q+m)ZHMXd>f`R&7O8ZJbKV
+lMh[Is8U6arUdk!bdF(5[%3erbcnk&b0'b]aoVP0r;SPNo@Tq`\"T:raMYs:`4Wt0X-fcs_R&1o
+q!6&#a0;#+]#DgmSZBoMb,^o,]Y_#6p\t0l&,u=]ZGX>PQ`IiqQ`\3Ma8X!W^](nF[/dN3XT5F#
+V?X06bdQHlrU^&>~>
+mf*jpm*(7Pc(Ti:EGB$*LS:ubr5er`rRLr+*U<(NY'IS+IY.Irs8Vr]`i&+DRtH*M]&:E3iV3?6
+rtC+bo[oo,eZ=UMM6#1qC3kJbL&_()s8N)Mr;SPLn'@TndAD\?@9dDeDd61NGDi`Zi25/to]!Ek
+jM6t.CN"T^X,q^BA9Ws:g#/jap&4mi&,u:[YJ];1OF1b\Jt'm4c2Pfb_#CtFX8o-sRfJ`PO9VB&
+m>BH;r:Br=~>
+mf*jpm*'_Ajk\J7c-*iHf%o9Cr8[k>rTF4Fs6L]XVJ3ThCiK:Ns8Vr]`h;\Zgsjd+iT[kZiV3?6
+rtBJPo[oo(kMOn;fAGcW=D2YpF8u/Zs8N)Gr;SPLn'@Kik2+\7Z_bUdbb]s+d+I:?fr!Emo]!Eb
+lJgOHbKSDghqHN$^<kNjkh2rip&4mi&,u:[YI`uWg="-feD0-Jjo4<@ir7p9hZ2O4g]6+-g'6Bp
+m<[=%r:Br=~>
+mf*jpm**&]YaV8g]>hq$Ssl@Mr2ft'rO)[<*Q6+E[^EZo_oMZRs8Vr]`j!C`Q_UUKVS'pUiV3?6
+rtEQRo[on^[@`trSY!75YeS6$b5_C^s8N)dr;SPLn'@cOZCIMq`l-!+^Vmq/Z(%GrbGNq_o]!Ep
+^SmHs`P8I(a)SsZS$aK_5.\'1i+p&4mi&,u:[YJRrLQ`J6BUR/*jYl:a)W;`[nT)bD\QN3<LQNin_
+a1Ts_r:Br=~>
+mf*jso\XW*i4kqFKmn5cF+oR7r0m\[rN-%2*Qc^^kO,mVFF<TSrr2c[`i&+DRtH*M]&:E3iV3?6
+rtL1co[oo,eZ=UMM6#1qC3kJbL&_2OL&_/Qf)>V)rqYfrV<Z0lK5Y",H&7,k>[VW.VU=h'cg:)O
+VVp.4N-K8gOLhF&OF1bbM6#1qT(a)EH0rr3N.p"ZS*fs-K\AR'/*S#i=_RfJZOOT((:L]2o+JGsp$
+JssdGQdEnQoDa=~>
+mf*jso\X#cl/LOPe^DghcILS$r7h;.rSRY6*TZAHlg1mP@qtN0rr2c[`h;\Zgsjd+iT[kZiV3?6
+rtKPQo[oo(kMOn;fAGcW=D2YpF8u:=F8u7?d/Eu#rqYfrT'YOneBFf.dFZmlV6S=shWF0ocg:)O
+VV11kf[.jjg>T*kg="-ifAGcWT(a)EH0rr3N.p"ZS#kht+?^ST0(gu$reh#5t+f)XD$e,[tsdKe:W
+jQq`M`;K6,J,~>
+mf*gro\[+"]Vq9eTr>6.\"T;gQN3KQTDtc/Xg5FQb.ja`_=7=#rqbs#Yf*Z1UT9cZ]Z.>;p\s=T
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drVn\Qq<>f"`3#B$^;\3sSYNp;`jhY2ZH8iem-`K&
+bdX:8Z+m?,VQH__X3.f?T!ce7eFNP:rt#,%goAT-Tpr=.`4i"5T:5bG!1*VNrgWt[rhBIiri6:!
+Q`\3@d,Foos*t~>
+mf*aqqX/WG_W8tMTTY4eK)U/qK)gW(M>rYXS#3I/dH'5?Eng'ZrVGj"Vs;BnK7&cli5)eZp\s=T
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)MrVn\Qp>NEti4G(uC2\BXUmcmR>]54_aQfS<jQ=OV
+mEM>YEI<kZi.J;HOF2&%TZuktbjPB-rt#)$g8=>hXGM(0;-\$lM1tq]!.Oops)n<g!.b'#reUiJ
+c0C\FbP^u3J,~>
+mf*aqqX/!#\*E)6h:gN3eGdnoe,\%tfDjPFgtpuLk3CWD@,(/HrVGj"T^:apeC*(0l+"+Zp\s=T
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVn\Qp>NEll/C@EbKSAebhU^lV9IHEjQrJTjQ=OQ
+mH*0Sc-k>)l$'>ig="6rh<"$pbjPB-rt#)$g8=3!hq-2bI\k9<f@BlM!7Uqqs3L\m!7UqsrmqA0
+jm7iQ`Vf?-J,~>
+mf*aqqX2)'ahP'TR[0G:U].=lUB%"dSGnipS>!!h^Wa6tg[G";qWl/*`3#B$X-fcs`jF_!roX4p
+b5LtbU<L$;S@"iY[EPkia3)R)s8C+?rrDHbs"jZJiO-S9VO+@'^TNurQ_V:5^S@-t`3-u<k/aLA
+YaV8sX-fcsWO/OhX1P'oYfEcfmed"`&,l1TVTcH?S@$>O`4i":U&LeeW;`jt[/R*+VZ*@iSHbFb
+`4sd\r:Br=~>
+mJd^qpj[O*\aA4t^TjH#OH>CuM#`>1K)U-<K85DNVSLmPQ+GfBqYBHsVWu9mK7&cli5)e[p\s=T
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)MrVo=bo%0_rfs-K\Dg@AOR%p.&DeON[]&:N6g"NpF
+jM6t.I#tqtnQ!<]]9%DlR`Oci_Wgprs8W&ifq\#dXGM(0;-\$^H2`3jJcLN(M>iS:Q2[6OWs60&
+oPWI0rU^&>~>
+mJd^qphaVJZ0gc:io&YJg=k3Wf)XD$eGdl:eCN:,hW!bdLUu=4qYBHsT^:apeC*(0l+"+[p\s=T
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVo=bo%0_kkht+?bgG,&R&f#lbfS;eiT\"^g"Np=
+lJgOHdb<[El9quCiS)`0guRgm_Wgprs8W&ifq[lrhq-2bI\k97dJhSne,\%ufDaJ(g]$"-hZi',
+lWi5drU^&>~>
+mJd^qpr'kP^;mghW1fZHR$aB(a)SH,;]U].;7URms?S>`p;]t3%jqYBHsYJdQ0UT9cZ]Z.><p\s=T
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drVo=bo%0_]\"T:r^TO!"V5]fV^<3LDVS'gRg"NpK
+^SmHsX-fcse=4FiVO+?YQ`\3._Wgprs8W&ifqZd!T:E:/^VmmoY5YL$UB%"eSc4uVQ2[-LSd)(4
+gp>etrU^&>~>
+m/IRoK7A0UL=#>Kg!.UL]!;16!2faa+HVV=HujO_LQf!flD_V\p%[glVWu9mK7&cli5)e[p\s=T
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)MrVo=`mE;6kc(Ti2H&f>hKr2t]Jo>jkZ.\'2bfcd>
+fs-K\JssdG_-N&cad[p1OLjAg\E!A`s8W&ifV7ibXGM(0>]54NNrG.>RK0#[X8][1`;[jWeHXt!
+QZ_N>rq$/?~>
+m/IRoEG]?tGK9+9kiLmaiSaXk!8d_1+PPN"da$4gf%T'Dm%_DXp%[glT^:apeC*(0l+"+[p\s=T
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVo=`mE;'fjk\J3dFmLBHCj3QeBH:li98jibfcd7
+kht+?eD0-O\4hD=jP885g>V;/\E!A`s8W&ifV7]phq-2bV9IH@g&B_)g]610hu;R7j8S-=k6C2<
+M.>bmrq$/?~>
+m/IRoaMbg%\]`%.\$3!3VP3pZ!1a%T+IJRhX1,@1SsH(S`3R5?p%[glYJdQ0UT9cZ]Z.><p\s=T
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drVo=`mE;NMYaV8sY*l&rV6m@kUV="&Tsr7Abfcd*
+\"T:rUR/+$_kXWXXd>f`R&7O6\E!A`s8W&ifV6TtT:E:/`4r(<RJrTQQN3KRT)PSeX8]7#[0F:a
+^UiXmrq$/?~>
+li.EIK7Mg$DMG[ZmHWWfg&0A#dJh30]!eJtHt[A<IZ1/OhPJTcp$'GllH,NJI#tqt_6r:sroX4p
+L&LYrU@6X6M04ZUeaI7!JqSjXs8@ZOrrCXLs$m"_jh7eZ`0GjuNjdd5>E%jhRtGd;VU=h"]==F!
+c(Ti2JssdGS7RiJad[p.NjdcjXPNRJs8W&ifV.caXGM(0Dh=FY[f3l;a8jKaec+J,kPjcGmfg[e
+F+!T/o)F4~>
+li.E8EGjWC>^*F*mHj*%kksTDk5OHAi?$k0d`TeZe(EO>g8!$]p$'Gfm,ZsOdb<[E\@(>jroX4p
+F8ba`U?h""f?`(+kNc5`E-$+#s8@$=rrCFFs$cq^jh7MVj4i&1g#;/[97H6ggsjX#hWF0k]==6q
+jk\J3eD0-OQ;`J'jP884g#;/:XPNRJs8W&ifV.Wohq-2bbgbG*rSdb:!9O4CrojFKrp9XM"hf1j
+C@faAs*t~>
+li.F:aMm#I[(3loa2GX'\,<W6ZMpsKVPBZKX3/;gW10<_`i@DPp$'H!`3#B$X-fcs`jOh#roX4p
+b5LtbU<L$;S@"iY[EPkia3)R)s8C+?rrDHcs$m"_jh8(=X-KNaRA7@AR'af6Q_V'_S?g8/]==]X
+YaV8sUR/+$V5h,FXd>fcRA7@7XPNRJs8W&ifV-NsT:E:/^S@-eU]..iXT5U)[Jmf=_Z%LQbQYtt
+\\[n'o)F4~>
+li7!=$\\/%HZm!"Um/^2i;E$Dmf)Joi8)elOF1bNCOVG]jLD\VnE7]clH,NJI#tqt_RAM"roX4p
+L&LYrU@6X6M04ZUeaI7!JqSjXs8@ZOrrCXLs$ltZgo\u[[Z5ZaQ,Mk5ARFoVXGM(OR`OceV4b6W
+^ls4rP/$)KPAFh!eZ=UMM6#1qT[iW2s8W&heXl6[XGM(<Jssd2h>Z@3l2^5Nmgm:N_4m0YQCDZ,
+]Q\dTqpk9;J,~>
+li7!+$ZblVBk=lTT8'h`g&117llbQVk2G%Bb-T:>g>_D%\)6]<_k-5Ugsjd+iT[k\j7rW9rtKPQ
+o[oo(kMOn;fAGcW=D2YpF8u:=F8u7?d/O&7rUemIb3@m<dF6k1lc3"#lf[0Wcd^b2m$X]CXm4p"
+e'ct0lKXR:;sWW(f?`(+kNeeko)/OfrU\R2lf[0WccjnojQGb+l2L#LmJcD^]!o/6KnbAP=^8UN
+CN'*ro)F4~>
+li7"-$H_qY^q@7XXh;`qqof&^rkoql]!A3#X3/H$W0XBs]slngkJOI@Xd>f`R&7O9[c@/^k5Q.<
+rUea:bdF(5[%3erbcnk&b0'barQ>0?!:Bdc7fDu7Xi\/LRBEEPX2<2WV9H?>S(a)#&XXi.38TY%t;
+QDgaJW5$rJZ)Z$UT:E9ZT!ce8eaiY<s8DQ>T$4U7S@$&+Q`[[,rk/6K!6>)_&&H?.^q7:oS$963
+]Y_\cmIL:-~>
+li6s<2#W&YJE5FsFE)5@ChmdZBqD8fTu#(Ci4G(uBjc";VU=h+cfjE(U?]jiK7K6*kJXplq#9FU
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)Mrr6C(n'RfrdAD\?KqQ]XTl+Jgh6r>iI#tqt_23g5
+eZ=UMKqQ]X\#XO`i7YAoG_Mg8m@_Yiqu?]on^<lpeZ=UMJssdGn'Ake_3:+KUM4MBY&A<#FEMfU
+H@4h)JqX-So)F4~>
+li6s*2#VE5DWKN]@UNJQ>$4t$=.>q=S%$E(l/C@Eb-B7ChWF0tcfjE(SF#=leC314laaReq#9FU
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)Grr6C(n'R]mk2+\7e_T?SP[7>0l/C=Cdb<[E\VYt)
+kMOn;e_T?SYH)&5g$%AHd+-t6m@2;dqu?]on^<llkMOn;eD0-Olc-NF[tTQlSl]'nY$PID@Uiut
+BPQXHEH;'*o)F4~>
+li6t,2#YM9`T5ar\[SrOZ*:I+Y+i57WlW?)]V_$rai:i_S?g88cfjE(X2M-,USa<W_TKFMq#9FU
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drr6C(n'RuSZCIMqTpi4+^oONY\tb[rX-fcs^km]f
+[@`trTpi4+^8n`HbI=17Z([Vja/I2Kqu?]on^<lM[@`trUR/+$bf[cCaLf*uX0/\*Y-k^J\[oH%
+^VT$NaN=GKo)F4~>
+li6s<2#i8_K_Y2kIsud#H[:"iH-j`V^2IeN^Yl_cHtd>EP/$(g^YmtZ`Se@iI"Ig.lD;5Xq>TOV
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8QW\s8W)ol,0@_ad[p&KqQ]XKQ_1:jM6t.GDi`ZheJ;=
+ad[p&KqQ]XT"oMd_r/.gI"7L#kH2M^q>UEkm`hftad[p7R`OcP@;2l`EH?5FcZsikhL'a#It3(>
+JqEcNKSBHWo)F4~>
+li6s*2#hW<Eqo:UD/=!3BkV23B@+h3^0Xs)[HZZ(d`Tb]g>_D'^YmtZ^$4M0da[(5m$YTNq>TOV
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8QWVs8W)ol,0+ZjP880e_T?SFCn^QlJgOHd+I:?fP6?2
+jP880e_T?SR_WK>]BS;.daQt2l_VAZq>UEkm`hQojP887guRgM:fsl,?t!PUcY$qGhJ6nCD/O:^
+E,kYnF*%B.o)F4~>
+li6t,+TKU,anYMj`5BI1^q[Y9^<k'7^9t24a1S:9X3&A[QDjet&E)EU`Or(7X.u#``4itKq>TOV
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8QWss8W)ol,0^CXd>fpTpi4+[^36X^SmHsZ(%Grb%dEa
+Xd>fpTpi4+VnfsO_n;k5X/;/__R@5Bq>UEkm`i,WXd>fXQ`\34Vm!82\%'#]cb(a)0KhSR.I`5Tad
+a2n%tb0'bOo)F4~>
+li6s<!<<%P#6+S\KS+o=rdlKhJai)WkBqQiBY`Q<OF1bfNjdckYLhI8`8J7hI"Ig.lB]<OqYoXW
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8Q*Ms8W)li3UA[]9%DfOLjB?BmjudlH,NJEJ:(1m;TS[
+TnRK8P/$):VU9^0\E(GhIXI6gi5;kXpAP!fm)c3kad[p7R`OcUD0FZ^IXZcsn:?2apAT^DKEM.*
+L&V(*!WUaAs*t~>
+li6s*!<<%>#6+SXEcH)Lrbs4VDt*13kA"YE<jq8Og="-kg#;/:YLhI8]]nD/da[(5m"rUDqYoXW
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8Q*Gs8W)li3U&[iS)`.g>V;]=)D<!m,ZsOc.1Y3m;0/k
+h:9cug>_DNVU9'aYj16%e'ct/l+=7YpAP!fm)c!gjP887guRgR>@lQ)Ci+$,n8E:=pAT(2EWc5\
+F8l/[!WUO;s*t~>
+li6t,!<<&@#6+SkaiMQJrl6AX`piE7kJ=mIY/e2PQ`J62RA7@8YLhI8`4Vt6X.u#``4<bLqYoXW
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8Q*ds8W)li3U>6VO+?aR&7OGY.D'T`3#B$]:k[ta*G"q
+R\@<kQDhRHVU</e]t^M3W2l;_]Y^u3pAP!fm)cNNXd>fXQ`\39ZFnr/_o0L4nA`NApAW/4aTMI`
+b5VC_!WVQXs*t~>
+li6s<!<<%Ps8N)[re2ebKnY3YK`(_#q1=1VF(X=_Z&EpMM6#1qU!D2o`8J7hI"Ig.lBfKTqW7_k
+L&LYrU@6X6M04ZUeaI7!JqSjXs8@ZOs&IYMs8;H=U[Qa7M04?6`95!TJotereZ=UMEJ:(1T$<s_
+EH?o4dI+ERhL0LDlH,NJFc!0Ln"\J)r;QQYa/A4ERtH<]aQet0II`$cq>,dBKS9@(qh51QKn]P\
+rr2uLo)F4~>
+li6s*!<<%>s8N)Wrc8'lrc9CaF8YoUq/L?3@T;"Di7QE&fAGcWU!D2o]BS;.da[(5m#&dIqW7_k
+F8ba`U?h""f?`(+kNc5`E-$+#s8(a)$=s&IGGs8;H=U[.+#f?_q#j6O-YEb&8;kMOn;c.1Y3RH<8T
+c-Fnsk3T+ZhJ6Snm,ZsOce%(;l_E&%r;QQYa.Ve[gsjj/jQqS/C[uK?q>,.0F*%?[qf;o?F*%A&
+rr2uFo)F4~>
+li6t,!<<&(a)s8N)jrlP5frlQPcb5D.Yq8gS7\Z<r`Tpr<oSY!75U!D2o_n;k5X.u#``4<kPqW7_k
+b5LtbU<L$;S@"iY[EPkia3)R)s8C+?s&JIds8;H=UWg-<S@#/YX2<&d^UpYm[@`tr]:k[tT<OcX
+]""B&ZH:.uhSQh-`3#B$[%3erbbNb[r;QQYa0<LaQ_U=BXi.i]_XbeCq>/52b0'__qoT'Ab0'b,
+rr2uco)F4~>
+n,ELhr;-6gKE2#NL&_/QjSji5PQ$7^s+ULQL&Zj[nTo&VjM6t.EJ:(1mA%_LYf,J3OF2YKaQf/4
+lh]`C'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Or;T@cm)ksfc(Ti2KqQ]XUN2*7D9q%HNd>>XKqZbb
+KlLLALSiJeHctZ'GFn6MVMB5HTZuktbjG<,qWl/!lH,NJJssdGPf8.JL&V)UL&Zj\s8VtM!rmt.
+r;QcJo)F4~>
+n,EXlr;-50Ec_6ZF8u7?i;RctKDop<s)\5?F8p<%nRu.&lJgOHc.1Y3m@VGHYe0/Yg="L+jQqfE
+lh]`C'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=r;T@cm)kgbjk\J3e_T?SQ=+lK>KH'fg!Rd`e_T?C
+e]kAEf&#QUD9M0\AXi&KhU^!&h<"$objG<,qWl.om,ZsOeD0-OL;e$*F8l1CF8p<&s8Vt;!rm=_
+r;QcDo)F4~>
+n,EXlr;-62aiaV^b5_JAoDZl4d/M06s2tBAb5]W+n\;BI^SmHs]:k[ta/m>/Yf",NQ`HmJXi.fj
+lh]`C'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?r;T@cm)l9IYaV8sTpi4+_RIFsZHKhSRBFZDTpi3S
+Tt87RT:E4/Z-2CM]VEWTS=[3`R]si3bjG<,qWl/*`3#B$UR/+$]Z%hbb5VDEb5]W,s8Vu=!rpEc
+r;Qcao)F4~>
+nc'.!r:faIk^J&6q1OHUs8V0ZK`I>9KdHbQs8RfQKn]8LEKTP.RtGX2R`Ocm_U#F'i4G(uJssdG
+R)nXjjo6$KrUea:n("LrFc!0LmqR0#KSBI+rIt4M9)eVI]Xd+=PC@M*TZukXG)CZeZK/fbIVW80
+KqX3??Yk7X`95Tkg@9`?VXN':M04?6`948;kP>)Qlc,jfad[p7R`OcY`ddi=rr3.Us+Q1,s8.KO
+s+Q1)rrCX@s*t~>
+nc&ppr:faIk\Y3Vq>PI8rrD!VEr^jlF!^j-s8R0?F*%(k?\Ie,gsjQtguRgr_U#Etl/C@EeD0-O
+Mob8]jo6$9rUea:lf[0Wce%(;lW@h>F*%B]rH%r;9)eVI]Wg\\g=+<sh<"$IA9r$!VX!0pe'"i;
+e_Sd#XNT)Ij6Oiug@9)pVX*F&f?_q#j6NPVkP>)Qlc,UajP887guRgV`bkQnrr3.Cs)W8]s8-j=
+s)W8ZrrCF:s*t~>
+nc&ppr:faIketH\q>SP:rrDZiaoKffasI)1s8U7Ab0'Iq[^sDZQ_V9iQ`\32_U#F']V_$rUR/+$
+]#a77jo6%;rUea:bdF(5[%3erbcnk&b0'barQ>*=9)eVI]Y;.ZQDhEhR]siB]>qdt`kSI<W5Z`f
+Tph[d`PSL;X2</eg@<1tVTcH?S@#/YX2;<[kP>)Qlc-0IXd>fXQ`\3=`l._rrr3/Es2rLas80q?
+s2rL^rrDHWs*t~>
+nc'-soB+WF^iO[Fl@O\Cs8V0ZK`I>9KdHbQs8RfQKnT/JE09G-RtGX2R`Ock^s/sui4G(uKqQ]X
+R*+gnjSonlo[oo,eZ=UMM6#1qU=b'NL&_2OL&M$DrUo!KdG;6kH@1gci:1T.N.5u(mEM>YEF3$l
+KlLI-F,-X?m]V!!p@Wg>`8J7hI!h$ei5;eUp&+[P`hr%CRtH<]aQf#0J,4lurrn,VKn]R,qh5+O
+Kn]I)!7p`@J,~>
+nc'-soB+WF^gUbfl>^ics8V$VEr^jlF!^j-s8R0?F*%%j?\@_+gsjQtguRgp^s/sll/C@Ee_T?S
+N6:PbjSonlo[oo(kMOn;fAGcWU=aF+F8u:=F8c,2rUo!Kb3@m<dF-b-l0;DaI;NM<mH*0Sc)e"k
+e]k2#cIUk7m&+X\p@W1,]BS;.daHk.l+=1Vp&+[P`h;\Zgsjj/jQqW@D>J>QrrmKDF*%B]qf;i=
+F*%9Z!7:<:J,~>
+nc'-soB+WF^pq"llH%)is8V]iaoKffasI)1s8U7Ab0'Fp[^j>YQ_V9iQ`\31^s/st]V_$rTpi4+
+]ZTX=jSonlo[on^[@`trSY!75U=dN/b5_M?b5M?4rUo!Kah"78Y,dqe][X1"b/Cp%a0;#+]#DY"
+Tt84_\=]:sagnqCp@Z8._n;k5X/hVb]Y^o0p&+[P`im=_Q_U=BXi.ll`;7XUrrpRFb0'baqoT!?
+b0'Y^!:B@WJ,~>
+nc'-kiPqq)a2=clc$k7ts8V0ZK`I>9KdHbQs8RfQL&18gCp<!9PC@G%R`Ocl^rr^oi4G(uKqQ]X
+MU(\gjSoeio[oo,eZ=UMM6#1qU=b(rrr<"P!WRlPs%<4Ze"6$YXGM(MQ,Mk&Dg[UsH#)m!XGM(0
+;-n6L:1/-uVU=h(JaWC0I_`,L`0GjqM6#1qT[`N/qWl/!lH,NJJssdGPfA4LL&V)UL&Zj\s8VtM
+!rmt.r;QcJo)F4~>
+nc'-kiPqjt^:9S9c"q??s8V$VEr^jlF!^j-s8R0?F8G@U>,:HCg=+9qguRgq^rr^gl/C@Ee_T?S
+IEq<ZjSoeio[oo(kMOn;fAGcWU=aG`rr<">!WR6>s%<4Ze"5mghq-3'gZ.V.?#"k-B3FQ`hq-2b
+I]UeqFg96ChWF0pEUN\uCquq6j4i&/fAGcWT[`N/qWl.om,ZsOeD0-OL;n*,F8l1CF8p<&s8Vt;
+!rm=_r;QcDo)F4~>
+nc'-kiPr.7`lc6+c,7TEs8V]iaoKffasI)1s8U7Ab51SWZ,=>TQDhQnQ`\31^rr^o]V_$rTpi4+
+\'FI?jSoeio[on^[@`trSY!75U=dNbrr<#@!WU=@s%<4Ze"4dkT:E9cQ)hdF[)'u+^9GhhT:E:/
+^W!e'^;d[TS?g83^(a)(jm_n`auX-KNgSY!75T[`N/qWl/*`3#B$UR/+$]Z.ndb5VDEb5]W,s8Vu=
+!rpEcr;Qcao)F4~>
+nc'-^a04poi8EeVW-3ZCrVtsXK`I>9KdHbQs8RfNKC@U-F5>6@LN@BcR`Oco`65"GeZ=UMM6#1q
+DU\.Rp&><sr;6?dqYU6jq>V90o[oo,eZ=UMM6#1qU"4elrVc_LL&Qf)s%<.Ra/A4ERtGX5TZul!
+F+3lVHuHjZ]9%DS=&!$r>&8_S`95UOL@kE@JBOYRc(Ti2JssdGW6"<#q<Q%ulH,NJJssdGPfA4L
+L&V)UL&Zj\s8VtM!rmt.r;QcJo)F4~>
+nc'-^a/J(a)jl07NeV.FL`rVtgTEr^jlF!^j-s8R0<EUV\pA(g#$f$;LhguRgt`65"CkMOn;fAGcW
+?ISHBp&><sr;6?dqYU6jq>V90o[oo(kMOn;fAGcWU"4/ZrVc_:F8g7Zs%<.Ra._k\gsjQuh<"$i
+@;P]2C0e=5iS)`&P&IF@T$,U;j6OjiG4b_0DTeR;jk\J3eD0-OU<)Zrq<Q%nm,ZsOeD0-OL;n*,
+F8l1CF8p<&s8Vt;!rm=_r;QcDo)F4~>
+nc'-^a10:/]Y),+XLuKmrVuKgaoKffasI)1s8U7>aR@orYf<u=T!uJ0Q`\35`65"$[@`trSY!75
+X4-V:p&><sr;6?dqYU6jq>V90o[on^[@`trSY!75U"76\rVc`<b5TQ^s%<.Ra0ERbQ_V9gR]siL
+\AS(6_6h:rVO+@*_S*q&_nr:9X2</a_t<m(`QP7$YaV8sUR/+$Z,l8,q<Q&)`3#B$UR/+$]Z.nd
+b5VDEb5]W,s8Vu=!rpEcr;Qcao)F4~>
+nc'9SXPhXI]=Z#7iG<diqYoQ0L&[A9KdHbQrqqE>IaturhU/3UF(T]X[b^G5bKQ^LeZ=UMM6#1q
+E7a^[q>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X9#eZ=UMM6#1qS'QTTo^qg.K(aiorVlfkjh&%`
+^ls4eKqQ]XKm&"Cq0mFMlH,NJDd5q0:1/-uVU=h8^P_gcr.3Fnn("LrFafLgjL;_]p\F-qVs;Bn
+K7]Q5lBK;<qM"qK"blu1L&_2MK`_:.L&CrNf(/ik~>
+nc'9SWnHRqiSih\fii$+qYoDoF8pmlF!^j-rqpd,Ct6(]g#h/BcG\,`iTTQ_bKQ^HkMOn;fAGcW
+@+Y#Kq>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X8tkMOn;fAGcWS'PsBo^qfqE;";KrVlfkjh%_]
+inDl+e_T?SG%>Leq/'Sqm,ZsObbf&mFg96ChWF1&^O#\Sr,:/\lf[0WcdLP,lE@e[p\F-qT^:ap
+eC<:7m"WMsqK)Z9"`s]bF8u:;EruA_F8Z%<d.73e~>
+nc'9SZH9MTVP^E'bd+t%qYp*/b5]ifasI)1rqsk._pu;gaKh>-\&ke@UUnmMbKQ^)[@`trSY!75
+Xk31Cq>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X8U[@`trSY!75S'T%Do^qgsa7dUOrVlfkjh&4@
+W0XBoTpi4+\@]`Vq8BhV`3#B$^;[e"^;d[TS?g8I^W6-Kr5R<^bdF(5[&B:h^V%/=p\F-qZ,Ec2
+USF0X`4X+.qTAg;"j6kfb5_M=ao_Ucb5D8>mIL:-~>
+nc*OK[-uPGOH>aGkFupAn+bmrL&R9iKnT>Up@*O`FJtS`dAD\?@;LIZ`95R;eBafVeZ=UMM6#1q
+ES:!_s8W)trVZNep@@V6hpffb^;J=Un+chXq=jUUo^V+fQg`J+M04ZUeaJ@(GLtL"fm7s@hL4ea
+qu$0FYL217Nd?)7]&<*nH%GnjJ9ZA-dAD\?@8BKj?uq+#dI*XPNVi_RK&3]Ii4G(uH&f>hd&Ypm
+q!?,$lH,NJJssdGPf/(JL&V)UL&Zj\s8VtM!rmt.r;QcJo)F4~>
+nc'9DXR#',g=k<Al]tjkn+ba\F8ggkF&i*Wp@)nN@]5OEk2+\7ZcghPj6OdNeBafRkMOn;fAGcW
+@bLDPs8W)trVZNep@@V6hpffb^;J=Un+chXq=jUUo^V+fQg<hlf?`(+kNdu6A_5Se;qYhuhJ;NO
+qu$0FYKH+gg!S7%iT]W0B5d_FDe<\Lk2+\7ZZeTUZ-LqWk3SV`IJa$BESdn-l/C@EdFmLBafF1f
+q!?+sm,ZsOeD0-OKu@j)F8l1CF8p<&s8Vt;!rm=_r;QcDo)F4~>
+nc'9D^Wa*WQ^<u<_SNXqn+cFqb5Tceb#S>[p@,uP\Yu4BZCIMq`knU<X2<8heBaf3[@`trSY!75
+YM&RHs8W)trVZNep@@V6hpffb^;J=Un+chXq=jUUo^V+fQcuk0S@"iY[EOK:][tfg;q\q$hSS[Q
+qu$0FYK=ANRBETXVS(E^^;g*J`kAb%ZCIMq`kJmq`jhY2ZH8leb5;2:aPO,A]V_$rY*l&raK+(e
+q!?,-`3#B$UR/+$]>VYab5VDEb5]W,s8Vu=!rpEcr;Qcao)F4~>
+nc'9;b4!l]M0t)UdGB"cfBCk=p@j[JJoL1-hpQSFL!f;8VMB5$?uLXcaQfS"h9hk`eZ=UMOLjB?
+F4p-[qYBp[oC)#,hUTfaYbA&-`lG$ifB`%tki(=Mf[S$HJa_-jM04ZUeaI.-BVD/pUMFYIER*V8
+q"!(5n("LrFaT:^i4s2VK)PX-JpVC^h6r>iB2q?'Ck.ehkL-KfO8]+XKB9bOjM6t.F,-X?m\%qq
+p[6;,lH,NJJssdGP.uJ@K`:rSL&Qd[rr)_I"T*k*rVlfr!7p`@J,~>
+nc*F?_!C1@f@&7,k1O9PfBC_'p@j)WE,b8_hpPr4Fis+6hU]uYZ-:_QjQr5-h9hk\kMOn;g>V;]
+A(gGKqYBp[oC)#,hUTfaYb@es]t^>SfB`%tki(=Mf[S$HJa;LVf?`(+kNcc;<hZ7^;kmK!X^KH7
+o(_e.V!I4$f?_n!iT[dUBlO%LE+rRtl/C=C`JdH]bL>5+lc?3`J,TEHETOj1lJgOHcIUk7m%)Ml
+p[6;%m,ZsOeD0-OKthI!F8l.BF8g6%rr)e:s)J8>EcV-Xrr2uFo)F4~>
+nc*F?cciegSZABQZH'5YfBDD<p@lhQa2dYehpT$6\&l[rS=[40`kS:8Xi/)kh9hk=[@`trR&7OG
+YhAUCqYBp[oC)#,hUTfaYbAD=`Q,6qfB`%tki(=Mf[S$HJ]tNoS@"iY[EN9?Y+_Sa;kpS%XgcU9
+o(_e.Us-6=S@#>aVS'sU^rQEPa2#%)\tb[rahbO*_PWU!_U,F?bl.S@aQ:(S^SmHs\=]:sae[;P
+p[6;5`3#B$UR/+$]>)8Yb5VADb5TQ+rr)f<s2bE@aiXM\rr2uco)F4~>
+nc*47am[c\M03lpVU=7AX2DYthr*F?He$BWZ(@3,mG6$aLN?m+F+Tk%lJl]gjO'LdeZ=UTOLjAd
+Ems7=lK@0_f?_FIY+_Mj_scmOi8F"D[FF'`_m?><U7RUANp=`UK5YmhX4?t5=OF+bi:--\TC1+(
+LNA'9aQgZ_I=qOuK77j9kJWX9D-KS>F,-X?m\IV[OT,:[K^6^ElH,NJDh=G!lD2;\p@-Ohn("Lr
+IZhJ,YdAcGK(o!4K(X_Io^r*6$A!`qJ:[ChrVliJo)F4~>
+nc*47_!C1@f?_anhWEL#X2DM_hr*F-C":JEZ(?]lmHN`hf$:UhcICY1m+PXHjO'L`kMOn>g>V;,
+@ajQ-lK@0_f?_FIY+_>^]BehKl07TM[FF'`_m?><U7RU;M!X3XeBH7jhrjb"=NRAUi:--\SF#Cp
+f$;e#jQsB`CN9@QEGT'Llf6aKbb&=KcIUk7m$>EKJc>]LEpLf%m,ZsObgbG/m%2)Xp@-Oblf[0W
+db<^GV6jt*E;0)"E:n0ho^r*$s)/22DK#4DrVliDo)F4~>
+nc*47cciegS[>kuS?g5>X2E2thr*G/^t$]GZ(AVMa1ALFT!u_W\>,Cm`7D3;jO'LA[@`tiR&7O3
+YLD_%lK@0_f?_FIY+_f&_p$'6]Y);*[FF'`_m?><U7RUKQc-"mUV=++T!e:9=0]X#nEnSub-IP/
+\"f:l`6Ga-aSu1[_mmP"X-KNu`4X+"T:E4/_nY?Zrr<#?lc?cXXd>fsUR/+$Xhs;qnC+,U[@`tf
+QDhR:[(u.Np\+=$ouG,Fo_li1`X)"O`qB0+rr;BVs*t~>
+nc)Y-^$jLPM039KLSiJe[@<=qYHkHOCnR8m`:*!Ic*j=$F(&HcF+Tk%lBlY.kg#aedAD\HOLjAb
+CqIj4`P/a]U7J-idI6Jci75rb]=Z>NZ*V*B]]&eWs69m3RtGWa@WdO/pXLeMmB4Okk/aLdad[p$
+JssdGPB25+rr7Y%GB`K&VMB5$:LJ7!VU=gVcgHtqs!`WjdV81#XGM(IOLjAf[,CTIfTP^RXGM=d
+]&:>mFOtothV<G1H@"5rrd"rtG^%>TGi%`Xqu51;s*t~>
+nc)Y-[-Qo4f?^qOf&#QUXI"rNYHkH=>+h:S]BehJjl,%HcEjdccICY1m#,>akg#[ak2+\;g>V;*
+>eA/$`P/a]U77dYb3SH\l0%-eiSinaWjB@;[+YBCs6L$PgsjQF\BidapZF'kmAS+ek/a:`jP88/
+eD0-OKjnn=rr7"VAS1;khU]uYGHoHEhWF0;cgHDas!`!XdT>bthq-3&g>V;.[,CTIfSo.Zhq-<1
+iT[b>@b5APhV;huBP?&Nrb)[PAnB.sBAVqGqu4t5s*t~>
+nc)V,`lti^S[?GHT:E40\tl%*YHkI?ZCmnn_p$'1YbRYY\&QG.\>,Cm`4NS3kg#pFZCIMeR&7O2
+WOp<q`P/a]U8"j)aiqfB]X=l?VP^T7\[/rJ_>DIV`!EK3UV=^f[%3f_[4Ai/\&dXmaK`[cQ_V9i
+Q`\3<\\uSgs2i6mZc]SDT!u_R`jhY2ZH9H!ma(n4.EV)-Y0=;GS@#>aVS'gRi:QTmWQ_cBS?&$S
+]Z-GOf>6A$gq_UX^Y%3<^C.ch]Z[t%hWjb1rpB:VJ,~>
+nc'0HRIA\,M0398F,-X?jR)E^rkh(<i:$+!i75rXToOhJA861.LP`(^`-6OKlH?0lad[p1OLjA^
+?]1/JV6.\_n*]K%h:9cg]<%KcOH?p,d?'OMjOsI]s2bP9K5Y!k<+:!,pT,mRg#90eh7o`Mad[p$
+JssdGQ$.\2s8Rb(H>MNmZ&Ep=<,[AWaQh5lh=Qm0s!`WngMGg$Z&EpMM6#1qUt5&,hO2^G[Z5Zl
+Z.\#UAuBONY,Q33CMTZ=rb;gTBU>]aLpG1^o)&FWs*t~>
+nc)8.O6budf?^q3cIUk7lL!oX]">S_f^%njl0%-dh:^?(^<=gJf%8gB]k;&rlH>shjP885g>V;&
+:Q(I3T;B3Blg4!'l0%0giSWGig'?U#acM\=lKJ0/s5XI@eBFe;MR_!apYRL[kh32lh7oNIjP88/
+eD0-OLLb:Cs8R.ZBj03Ri7QDkMTjT*jQsunh=Q@!s!`$]gKN:oi7QE&fAGcWUt5&,hNQ%FiRuW2
+i98d6<2X!*Y,PR!=]qJnrE'D-LnfcOZHD.squ60dJ,~>
+nc)Y9[*5qLS[?GW\"B1r^W4R@_Sa:4bfn5J]X=l:R[KkYaMt`sT:MR]^pLo8lH?NPXd>f`R&7O.
+S;WW<YI29hbf[l=]!\cCVOs3@Q^=JYaH2S/^UO-Ks/cQnUV=^^_8ipRpR`t2\'2).h7p)1Xd>fs
+UR/+$]t;8*s8U6^^p;1nTpr=._7ub3Xi/Yoh=T(ns#A0ngTo&4Tpr<oSY!75Ut5&,hQY27URA9S
+Tsr3dXJ`D/Y,SY#YcsjrYct=7XhV3W]<]T<o)&FWs*t~>
+nc'0VN6pChNd>MP?uq+#^s1EcrSSpRe^;LNXIG6(H?!kGIYWcWX4>"cJq))3aJeCGRtGX,OLsHM
+n,MYikMY1HdE024XJ(o@M1^8)MlYCsFL1&DZ2C^'RfS.[raGtABP;P_M(>%9lEJOb\AdC<OF22-
+X4?ZQG_(PJs+Q)REO4`APC@:PDh=G!lBHDSq31gX,),dNE5LPFOF2&%TZuktbO"i\Tu,a"OF282
+Z.\U7d)!W:p$_nF#4:BQ_rC@fo)F4~>
+nc'-UK#m38g!S!WZHh%XioTA$kp,ETk2bLYgtC6*c-4M^f%8d9kI7I4D92%aU?psreBH@piT^@-
+s6LTgl07BnjPo.Uh:pZ8eC2juhrj<IX6S^&r87P0!S#?m\-'[kaj9_5/)94PWm0/*^$4M0da-P&
+kNc2]DfYmXF)bu&WTrKse'"T3eD0-OL19BBKDtlpF8+[#\EVu+d`p=ujmAV^m.98,\*;l*da6Y)
+kj.QV[^s'Cli-5TmFnMViq<9@s*t~>
+nc'0VZcp"URBFEJ`j_P0W3E\@rOaAa[Bcp3T9kt>Y.DBTW1TWNT!cJ9^r5@#aK`[cQ_V9qR&7Oq
+bl>Tu_S!IfZE:(#T:2%3S>3$`S"@%3FLf/bU&:P_QN<kqrl5,_b0%*cS1Br.`4=.E\Ac+XQ`IKa
+T!ceF]uJ1os2rF"[_okYQDhd@^S@-t`4WYEq9]-@,0KZ>[E#qWQ`I`lR]si4bO"i\\B2C\Q`IB\
+Tsr7iaN268p!!ER#04rt_rC@fo)F4~>
+nc'0cRtpCUVMftKDeO3IPG,(drOX;ZXJVJKM1^+oFaSdtP,>;-e\H%JMh9@BaJeCGRtGWmI#tu>
+ec3`.`4NIZVONd0M1pJ-Fa&4bMne?DB^aKQN;SP4K)foiFT?^[Hn9lHdI+0[e?m0P]9%DfOLjB?
+CjL\ds8RfLJ9?_9c(Ti2A:Tr`kMg9&nbeUMruZskl#`9Wad[p$J<e(9Xha,ll)U*7ad[p$GDrfW
+e_U5_p!s&`#0kigWQso-o)F4~>
+nc'-bOa-9ThUp<(bfS/]g>1Zai?R:<hV?i:eBuOedaZn&hV[JY\6I:+EQd[hU?psreBH(`g>W%o
+s5Y$WiSi\NgtLH5e^Msmd*gFrip,fBlf[0Xr7Ctu!6tJg!7CJf/C`P=m&8(V[(PY^g="F'iT]W2
+BlJ.ns)\$SA:3e+h:9cae(`pKfii%Yr.G"K*cq2B@Z'O5gsjQsgZ.Us^ut@SV2"?tgsjQpf\krU
+rTX"<ro=:Fkj>1kmJ?DRJ,~>
+nc'0c_RddlS=?C\^WO$WQC=G@rMCg5T:D77S>36u[&]smQCOPP[D]AsaN3T2aK`[cQ_V:;X-]^_
+[K!?GX/;YaS<oP0S=ud[['?[,S#F*RB[!lVS,AfVUB%q)ZiI9%X":$9ZH9W!e?m0,VO+?aR&7OG
+Z,"E&s8U7<`OiS!YaV8saJP6'_UPj)nbgc5ru]D[l++@CXd>fsVNn4![_V(ul,(-PXd>fsZ(%Gp
+[CZ@MosOe$#-bSWZ-Mb5o)F4~>
+nc'0mWH+9hdBSspJp_c`IYEW=rK&7_M2-_2FaSXiM3+1,^X:TgUi1MBOG)'LbGsjLRtGW]Bmc$A
+XT+b,Q&q#_LP(&%Fa8@dLP_+]X2!`#EpqP[M>_f(J:`B,rJ:N7oT1T#dI*ONf!WHS]9%DhP/$(r
+Dg[1ks8RfNJU2A*eZ=UMFb#q%lD8QNp\pBUruZslmWXTVc(Ti2I#tqt_m\Rsn$RH/dAD\?A9a'7
+XLA,?orS.^#GJT^e%=]9rq$/?~>
+nc'0mT4!H@k2>"HeC)^he(*('rRrLKf@JI"cdL7kf@o$;io]FXT3Z'nJ9&m$bG=LcgsjQ8b0o#C
+huDIKgY1?4f$r0rcdC1jf%8X2hr<ptEpMoGfDX,"e'umtrRV&&o\(hPk3SD[f!W0TiS)`.g>_D0
+?>FP%s8R0<DeNVGkMOn;cdU\1m$V9up\ogEruQ7YmU^h6jk\J3db<[E]XHhln#pHlk2+\7^<kNi
+hu2O,hu;C9h;RS@]B&bdoDa=~>
+nc'0mcaUU+ZD!PQUT:Z/W1f`LrKeauS=ZLV[&^.#SX>b8W3WhNX0fS)c,o5;bHo-hQ_V:4b,^m.
+TDt5pQ'[o/Sti6e['$I)T:M@9SuBEEEm1q`SGfJjVPBo[rLEqVoU%/!ZH9;rf!WH/VO+?^QDhR:
+[DL#-s8U7>`kS_$[@`tr[&01l`4rh"p\rP=ru]D\m_$$LYaV8sX-fcs_m\Rsn'&2^ZCIMqaK_5,
+T;2C_oq25M#F_F!b.Ha0rq$/?~>
+nc'*rZ?pShmb,O`RZNG_Jq3]F,(P8sLP_+UR]F$@e`?/&Uq_5+pQC6[nC"9&c(Ti0C1q:.re^Z-
+(k@![H$k-oLP_%QR\m-saOTA/FcG>4Z','I"-o=DT`(nk[e.-]aOSk7gYKK]i4G(uI\tN\]5rFR
+L&_1,re#WFZK/fbM2@86lJlo1Jc#J2rr4'orUY>Wi7YAoG_1dQeaKa"o^on;_Vi%fIWojXM2@8l
+OS+J0K*R76eaKa"pAX[`J,~>
+nc'*rW+fV4m-*KfgtLE3eC49B,1G&kf%8X0gu%)OkN_E1U;(AZpOdP4nC"*!jk\J2bK7lSrn%2"
+(Xpg[dF-Lnf%8U/gtprIjQGg]A<#:+i;D:2gYCT?rSR5*/*,m<RbQZ1^$4M0daI"7m'L5=EHD0[
+F8g/pC8^@Vg=Os0jQtT0B5d\IKDtlmF8b]EAD-2)f[/."hrj=0ht6QO?ao:Yg="?nd+?n&rn@%s
+rmV2)hrj=0htI'@s*t~>
+nc'*rftb&#ag\=EQ^F87USdmg,,V-1T:M@8Q_((V[D0huWP?3epX%(KnC"P]YaV9#`lcH)rga"`
+(o=:9Y,eFpT:MC;Q^jYEXgPpcZ&Qu:TpGYE"-o4>Rf/fXU\(E6XgQ]ggYKK\]V_$rW1:08`4<h-
+b5_LarlDsc`kSI<SXl1N`7D-+`r#e_rr4(_rU[h0bdX:8Z(mk][EPl4o^p_Cah4L;W3Nk;S=H#H
+Qh?mJUBd?][EPl4pAX[`J,~>
+nc'*u\:Aq>T&AebaL\XRR[*`2+-i:`VQ7;CaOT56hQihocf9S/rKDrco\?(sfs-KfIf+R4J:`B,
+M2@7SQ("SN[^sQ-e_o`LZZC,kVru=>rON*LaN2X)eH"Fti%+*MXL%-P`i\FBQ&q*)dI*cSmt?Dp
+s+UK+J:`(7dC-*V[`Ia4I=?hJs-*H^+GKgiIXAK`^lsA%TXs(OZJbHOaEMptdAE(bLOsu&I!>7+
+!."Qk#_8APh=.W*pAX[`J,~>
+nc'*uY&A$fS([,kjPf%RgtV\Z*o#K*hV[;OjQGdofqt?Jcf8q`rI]1;o\>qhkht+CqpHG4eC<%#
+f@em4gtprIiT0.al0R*$@pcL1lfI.)i</-$jQ6@'!9j(>/*tuiXm"ldU[-spg=kEGm%J%[Ec_9\
+F8p8uEbXn&iSWPOjQrUXCiTISKDtljF8krNCT?[Zg=4X.iT]X5i:cr_ASLMnhV-W5eGdkrd.P]b
+dJhQ"e(ipGlEB+=rq$/?~>
+nc'*uho<IFU<UQaXeqe^Q^.E7+-i1ZS=ZUVXgPg[ai('bcf<$drQr^Ro\?Un\"T:dW;N\8VPBo[
+SXl19Q'\#4USb0![CjH"`NZeU^r!=SrMB[tXf\i+[/df1]IUqCZ-):l`kK<jQ'dr/ZH9)Zn&``P
+s2tA``P8k(ZD4"_UTMJ>]#2Vgs3UcF+Nj]Y_mm\#W0X3RR\maIZJbHOhn6A>ZCI5MT;/?cX0M?)
+!3Z=%#c<r`]$de>pAX[`J,~>
+nG`s0KRr(&CnoqRi7ZN!`;7%e`5p$Ie_oNRn&(E2ER0%"p4S/"PD.Q^kH_PW^oNoer/_k_R[TnM
+X1#UXaO/Poi9Kaf`2@ZsK6u$j_sQO`hui0-lL"Q=!7:PW0Z1`C`58R!cc#GDeW'"E`4EP$e]#+I
+p4S/"s+UK+Jr+Q8mG6=Ch<MtfL4P$Xs-*B\*rCJ?JDS\YR[Tn\m`*$(q#&EcF-Z%<^TjZ)P)tc`
+on`[/rf@DNR^VM2]&`YcoDa=~>
+nG`s&Ec9mW>*dk.l0.9jj8.^Uj5f:`kNV9ulb&!^@*`TTp2Y6SK6,B6kH:lNinrPgg)Jf%gtglF
+iSihXk3(smm-NE<TjqMPC!p\*mHXZ7"7,=?mJZ>PaL8PS[kPG'\%K5IB@"<`n(!$Vk2YFZjQF7g
+C\Dgjs8R0?F)cJ7M!aEhkNM9I[WZS0s8R`Lru1cQF)p!si8!,DiU".jk4nkrCLN%ck2P=Uh#?"-
+f_*hrg&B\2gYCcSah$R.rq$/?~>
+nG`sVai<8[ZGFc']XP2KX88\8X0&M0[Cj8mbeq,t\'MnXp;tJWd)tbNkJ>0QW1K?Ar0SFgQ^=/4
+Sti0`Xg5(a)G]Yqq6`3HPV^qeC+b/_9q]E?$h`5hi#!m&F&qoCJ.aN2<A[C"97oC(5:b-J(FVQI8B
+]#+0`b5_Las2rF&\\?+q[C*Ta_7%8$aoDCfr;Ri8`k]"&ZD!VOR\n3S^ZP=hk/+XB`3Q>8S<oP/
+R%*c>!1EhR#aLaO`7)<Yq#9mbJ,~>
+nG`s0KnT*^H#n&*_;ObHkPF*YkN_@#n%cGuC:&,:II;^`rIot*PD0&7n\fXgjOM>dr44>qaN2WV
+e_T0HlL+,e_53cF\As8ONIgDKEJV6G_84'kPc0=NC29cLDYe9*[;^)AF0C>achd@tO-f:ti8EnI
+Y18(!Kn]R,L&Zj[NdPo(dI6POQFPP*K8'@*PPkG%rI]rTRd/SIaN`Q/HID9ZrmQFFEL#tQg!RmU
+]"50>WrTU-\d-0pe`rLFm/$;QJ,~>
+nG`s&F)pp:B45;E\(L'6lh]iGli-5ilaF$Q=L;R[C[Q0<rH!&[K6.(jn\AeIlK@6fr8B-cjQ,Fc
+kNM0rm-O&Y\"B1#\Ar`.I;eFo@!T)l\$s#HKqW]l=BVT(>[@550XY4nI:9*ulcK"sk(JTXlfm[#
+afa04qK$`Xs)\3]Edhb3Gf]4:aG@@XI;s?.s+C7L*rU))D2moGjQ,FdltXu;qu4iYBjZ\_lKIBk
+io/kSp##`,#NOn.m"rsQqXXZ:~>
+nG`sWb/s;>^::DQaNVcE_YUne_SjC7bf@E1YdD!X_X>J@rQ<:_d)uCdn^Fke^U:2Br2(sEXf\h8
+[CX#f`6$6HaKD;B\AuJ(b/Wba\%BGoaN2<-]<SoLYHXt,[']V9+Lel$_s?I]p?''(ahk^'`5o+3
+`qmj#s8U7Ab/qiC\@VX_#emh#b/ha*s3U]D*rX1#]"GtjXf\h=ag]^equ5m#^p^u!^ULMNW2?Gc
+opu/Yrh]q$XgQ*^bj>2ss*t~>
+nGa!1Kn]L#JUW9nEGTluXi^IV+/5QrTVZS?Fa;npNe@4^s8Re,s-*K_rqY&rDmSotjS[pakN_@"
+n*eT=U6Kk;DK3VAL#_KZK9Co_NI5ug]5V`#^N@SAG^=\jh>)FPidH6JI`RTGec,I;SooCU`knis
+e*;SaKn]R,L&Zj\Ob%q)EGi"#G2;SJKSBI+PPbA#qi6GYXPrI0mEp6&k4eiSeV&L#F*Y(Lmcrlk
+i7[eR!8[Y4#NtC@V/kMdrUTu=~>
+nGa!'F*%<TDesR;?Wq*9VSrA@+-iFQSY]W*A7sh;IW>7+s8R.]s+C@OrqXo^?)[)UlMTlqlg4!*
+lg)U#Q%ipS>[PFrG2qn;EIr6+I;3B3]3epV^LG;rB4tu5h.le%0]Hk`P\e3dq9T';o9*TuR(g).
+?IS1ZrH!&[s)\3]F+J7FARJcI?Y&!\JTGo4s+C4K*W(;0CSoeOm-Vl.AENXbs3G_(Bjk_Rg$J(j
+l07F)k5a`Fkm-P@l^2,=o_n@\J,~>
+nGa!Xb0'\X`l#[7[^*9F[_DX[+2G%mV5:Q4]>!4AbK0S's8U6as3UfGrqYTi[)U>.^\k_n_SjC5
+bfn8O^qI(YZaRg!_rL(+aNr!'b/(d/]=,/Z^U_J!^;%G;h8/s)0]KsdcGSSaq<\+Xo?=eT_o9a+
+[F=E^rQ<:_s2tAab0J#D]XP8P[_(A`cH=<0s3UZC*W+$u\@0W"`5g*1]B8kds6[qJ^pphlbfRf<
+]Y(`H[/df;]Ec<lbepsKo_n@\J,~>
+nGa!1Kn]R+KS,<NI<p.[_5dEP'le<6G1,&kk(&$VKT_&hL&_1,L&[A9s#'c2N-]QCWj9IZ_nj9c
+Pa-upCMn*4Fa/4[IHp9^p\L&,PD0!uJq3+II=:5?J*hc;JqE[hq1C6nK7g1Vdus^]s8MnoIX-(P
+FO#7#pOrR#L&_1,s+Q/jKS"`'I,B@&o_Oc*rr2t^qu7]9OcG4<G*nVtE-Hd'r;ZfJKnP#*G]InN
+Pd8-Bi:ZOHcbRB9UR%s&I.7"3o)F4~>
+nGa$(F*%B\EcHQoCM@D&_5:T=?N4@H@Dud*fkTYeDt\4'F8p=]s)W8]KDtm.rRuX4@Afp!\%KA_
+]Tn2+GFhuC?=@>UBPM>Jmsk*.JocQcrdf$,l/c\rjl^LJDf9T6p%J3$/GO4)SoN#-rm:]Eqj_J8
+A&2X"C$kY9s)W8]s)\3]F+\LPDJX(FCMre(a)K6.%l!/(1K*WCV=GK=BRM5O]lD"RZ*s3Ph-Deirn
+AS?gq\%:5blO1bA\%S)`X(,o6qYp'cJ,~>
+nGa$Yb0'b`aiMZk_SEk,_7(a)#R[K!ZL\Ac).ftlgi`qIO#b5]Was2rLad/O&&rU%_A\>Q[PaMYp:
+`5'!u\Xp(4[CEf]^VRePn'(P&ccXVWrm&R(l/fe!jlaSL`l?'>p%J4&/GR<-fZ<@)rpBabqpr[!
+]"tr&_!Um=s2rLas2tAab0\8N`P]OL_Su0Dd)u@f!7:WC*<+7,`5o:#^U1G^_t<m,s6[tN`koF!
+ZF%<aaMRSn$d6T3`500g]#!n4rpp)>~>
+nGa!1Kn]R,KnY]dK7\[@kg'*Ss*bXHJFW8`q1OG#Kp.5jL&_1,L&[A8s"<;nJUZ7pF)eXrE4U+4
+Fa)>]I!pHoJV&K+qYZNUs-&/#L&[?iK_kIrKD>7qqu26ML&V)IKc'iDKs$-\PQ056s8K*PJUcm5
+mXk<6L&Zl+rt'naKnY_EKS4u1pOe.trf`'8rrA8ZruI;cO6MFEGh%1lK)GWJs42mXKS+f(L3Ri]
+E3X7rrbE.@C20K<CMRa'DfE:/bh7GsqYp$bJ,~>
+nGa!'F*%B]F)us0EH#j_kfWg=s(iA6DXm@=q/UQUF+\Q6F8u8]F8pmks"E8\Df"(L@:-IN?b0ZT
+A7a8(C27X'DfB]9qYZ!Fs+>BFF8pl6Er,QNEVT?Mqf;[Ws8Mh8)#nYuU3"\6s3UfGrh+7LD<Pj)
+E;KNSs)\2>&9IkmF+\OTEcH*nEH;$WK6.%l!/(.J*J8oml$$cPeS8uAr;Q`rcuX8KEGoZ:An,7V
+Z!1E2=V@H2=JDQn=^#$8?FjUifkbX(rpg#=~>
+nGa!Xb0'bab0&',aN)<ekhZ0Rs2,N8`UWTAq8peYb0\<2b5_Lab5]ies"Erg`l$HP\@/iR[^ruZ
+]=cY._8=+/`lH0AqY\_>s3Sp8b5]i2ankeRaS>SQqoSi[s8Mi:)#qb$grf$2s6]jdrn>H5`9>/-
+a85bWs2t?@&Bb$qb0\;RaiMQtaN=D[d)u@f!7:TB*RN*Ul,:<Le\T5Gr;Q`rmE3SnaMu-8]t1_^
+Z*LY6YS*\7YbInsYd(L@[CWomfu(l,rpg#=~>
+nGa!1Kn]R,KnY`jKnP-Vq=so@(ANN7qLneFL&_1,s+QYjs+ULQKn]PjrVmSmPD"S[m='KDidKp;
+It3+@JqAW-re1<*s8N^qs8S::PD0%#Kn]R,Kn]R,L&_+*s8VnK#lfU4Y(bGjs472L%'G;;K_^;u
+K`;"*s+UIP"GQl0Kp2Fg#6'=1s8S::rr2t^qZ$SZ#a5"EJV!BDKS9=(!7q+&$&!qlJUi2ti8&bZ
+HN2V.HJ$nsH@(!dIH>tHo7M_qnGe"~>
+nGa!'F*%B]F*!!6F)uC!q=so.(AMlhqJuN4F8u8]s)Wg6s)\5?F*%A6rVmJfK5tu'm;6Y!ibRXl
+D/O:_E;jkWErL.[rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%RU2t?qq/Z@R
+rr7'>F8l1BF8p<&KD]cprc</\s+>Clrr@]Js8R]WK)'q8Dt7mgF8c+=d/A"lEcHVJDJX+Hh.ck%
+s4@Eef\'s;BaAHhj_aGWEH;'Js*t~>
+nGa!Xb0'bab0&*2b0%j'q=sp0(APtlqT8[6b5_Las2r^2s2tBAb0'b2rVmK$d)jB#mDQm%ikjfp
+`5Taea8X0[ao9H_rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ogrda\q8rNV
+rr:.@b5VDDb5]W,d/;#jrlWC`s3SpfrrCFBs8UFOchYi*`q%3mb5M>?mJY06aiM`H`P]RNh8'$)
+s4(a)Fgf\+%=^^.cnji$TYaN=GNs*t~>
+nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]%-3V+L&Ln$KD>4opk/R!
+!<)\Hs8N^qs8S::PD0%#Kn]R,Kn]R,L&_+*s8VnK#lfU4Y(bGjs472L!3Z<T#lfVYL&_1,s+UIP
+"GQl0Kp2Fg"oj:1s8S;]rrA8Zs8J2brfVqfrVhNLrrCXIKa*]nKS+pOpAKUCoE'X;p&0LBK*D%'
+qu)5&n,In~>
+nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M%,cbZF8buUEVT<Kpi6:R
+!<)\6s8N^as8R^mK6.'FF*%B]F*%B]F8u2[s8Vn9#leseU3"\6s3UcF!2BI6#leuGF8u8]s)\2>
+"EXTaF+aC3"oiXbs8R`Mrr@]Js8IWRre#63rVgm:rrCFCEs@8;EcH*npAJt1oE'")p&8q0E<Z,X
+qu(SWn,In~>
+nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E%.higb5M4YaS>POprNHV
+!<)]8s8N_Ys8UHgd)uC8b0'bab0'bab5_F_s8Vo;#li&igrf$2s6]gc!8RRr#li'Ib5_Las2t?@
+"Npbeb0^(/"ol`fs8UIErrCFBs8L@Jrm8d/rVjt<rrDH`ap-57aiMQtpAN&3oE*)+p&<#2a9D@\
+qu+[[n,In~>
+nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO
+s7h<Jrt:Oqs-&/#L&[?jL&_1,L&_1,s8@ZOs7q?Ss+Q00L";Iff)G[LY5X+\s+UK,s8RfQL&V)T
+L&Zj\s87QSs+Q1,s-*E]!0d9Zrf[KbPD+_jre:=N!7q%$!0dA8s8MtNs8<"Prr2eK"oj;Vs+Q0q
+s*t~>
+nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!=
+s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%FUAf3>s)\3]s8R0?F8l1B
+F8p<&s86pAs)W8]s+C:M!/(.Jrdt@RK6),6rcA&<!7:Ua!/(5ks8Mt<s8<"?rr2e9"oiZDs)W8M
+s*t~>
+nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(?
+s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ch#>G%s2tAas8U7Ab5VDD
+b5]W,s8:"Cs2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:\es8Mu>s8<#Arr2f;"olaFs2rLQ
+s*t~>
+nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO
+s7h<Jrt:Oqs-&/#L&[?jL&_1,L&_1,s8@ZOs7q?Ss+Q00L";Iff)G[LY5X+Zs+UK,s8RfNrre&U
+Kn]R)Ka%L1L&_1:rVlk]qZ$PY"TO[>L&_.+rVllKqh5$6rIt:OrIt:O!ep[Sqh54RL&_1,L%#%l~>
+nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!=
+s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%FUAf3<s)\3]s8R0<rrdEC
+F*%BZEs;SbF8u8mrVlkMqZ$PI"TO*qF8u5\rVllEqf;airH&#=rH&#=!d"DAqf;r@F8u8]F79-Z~>
+nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(?
+s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ch#>G#s2tAas8U7>rrgLE
+b0'b^ap%gfb5_LgrVllEqZ$QA"TQikb5_I`rVllbqoSocrQ>0?rQ>0?!m:QCqoT*Bb5_Lab4#@\~>
+nG`O$L&V,PK`RD;re:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO
+s7h<Jrt:Oqs-&/#L&[?jL&_1,L&_1,s8@ZOs7q?Qs+Q00L";IcrrB5$Ka.R2s+ULQL&CrRL&Zj\
+s87QSs+Q1,s-*E]!0d9Zrf[KbPD+_jre:=N!7q%$!0dD9rr;qNs8N.Ss8W(P#lfU4s+ULQKn]!q
+J,~>
+nG`NoF8l4>ErgpnrcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!=
+s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^?s)W7UF3oR;rrAemEsDYcs)\5?F8Z%@F8p<&
+s86pAs)W8]s+C:M!/(.Jrdt@RK6),6rcA&<!7:Ua!/(8lrr;q<s8N.As8W(>#leses)\5?F*$gM
+J,~>
+nG`OKb5VG@aoTlhrlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(?
+s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seAs2rL>b3dRRrrCjRap.mgs2tBAb5D8Bb5]W,
+s8:"Cs2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q
+J,~>
+nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPtLhjHG:Os8Re,s8RfQrIk7O
+pkAbJ&sN@qPD,3Ss-&.js8Re,s8RfQrIt:Oq1T%QKnZ[`es$%3!3Z<T#60DWL&_1,r;QqSs+Q1,
+s8@WTs+Q1,s-*E]!0d9Zrf[KbPD+_jre:=N!7q%$!0dD9rr;qNs8N.Ss8W(P#lfU4s+ULQKn]!q
+J,~>
+nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5(a)KDkfXi.H)ls8R.]s8R0?rGqu=
+piHK8&qg5aK6)Zds+>B6s8R.]s8R0?rH&#=q/Zc?F*"'sd"D8r!2BI6#6/cEF8u8]r;QqAs)W8]
+s8@!Bs)W8]s+C:M!/(.Jrdt@RK6),6rcA&<!7:Ua!/(8lrr;q<s8N.As8W(>#leses)\5?F*$gM
+J,~>
+nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/EtPo?bY&s8U6as8U7ArQ5-?
+pr`X:'%$[Yd)s_Xs3Sp2s8U6as8U7ArQ>0?q8rpAb0&M^mEke2!8RRr#62jGb5_Lar;QrCs2rLa
+s8C(Ds2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q
+J,~>
+nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPkFfPD+_js+Q1,s+ULOK`M/J
+L&_/cPQ1ZHKp.5js+Q1,s+Q1,s+ULOL&_2KKa.R2Ks$-\PPkF\Y5X+Zs+UK,s8RfNrrn,VKn]R,
+rIkFTKn]R,PPtL]PPY:aPQ-jHPD+_jre:=N!7q%$!0dD9rr;qNs8N.Ss8W(P#lfU4s+ULQKn]!q
+J,~>
+nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5@KDb`VK6),6s)W8]s)\5=Erc78
+F8u7QKE(t(F+\Q6s)W8]s)W8]s)\5=F8u:9EsDYcF/!a&KDb`LUAf3<s)\3]s8R0<rrmKDF*%B]
+rGr/BF*%B]KDkfMKDPTQKE$T(K6),6rcA&<!7:Ua!/(8lrr;q<s8N.As8W(>#leses)\5?F*$gM
+J,~>
+nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/<nNd)sN2s2rLas2tB?aoMJ:
+b5_JSd/X-mb0\<2s2rLas2rLas2tB?b5_M;ap.mgb1t/,d/<nDh#>G#s2tAas8U7>rrpRFb0'ba
+rQ5<Db0'bad/EtEd/*bId/VJmd)sN2rlY3>!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q
+J,~>
+nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPkFfPD+_js+Q1,s+ULOK`M/J
+L&_/QPQ(R`Kp.5irs4>Ys+Q1,s+ULOL&V,KKa.R2Ks(I,PPkF\Y5X+Zs+UK,s8RfNrrn,VKn]R,
+rIkFTKn]R,PPtL]PPY:cPQ-jHPD+_jKn]I)!7q%$!0dD9rr;qNs8N.Ss8W(P#QKL3s+ULQL$ntk~>
+nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5@KDb`VK6),6s)W8]s)\5=Erc78
+F8u7?KDtlPF+\Q5rs3]Gs)W8]s)\5=F8l49EsDYcF/&]]KDb`LUAf3<s)\3]s8R0<rrmKDF*%B]
+rGr/BF*%B]KDkfMKDPTSKE$T(K6),6F*%9Z!7:Ua!/(8lrr;q<s8N.As8W(>#QJjds)\5?F70'Y~>
+nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/<nNd)sN2s2rLas2tB?aoMJ:
+b5_JAd/O%Hb0\<1rs6dIs2rLas2tB?b5VG;ap.mgb2!$ad/<nDh#>G#s2tAas8U7>rrpRFb0'ba
+rQ5<Db0'bad/EtEd/*bKd/VJmd)sN2b0'Y^!:B[+!7:_frr;r>s8N/Cs8W)@#QMrhs2tBAb3o:[~>
+nG`O$L&V,PK`RD;re:@OrIkLVKn]P\s8RfOrrRn<L&M&OK`V4;r;R+fs+ULQKn]R,L&_+*!<;hJ
+qu6_OPD/o6s+ULQ!/:FPs+UIPrIkCSKn]P\rr3#MPPkFaY5a30s+UFO!/:@N%u(%;L&_1,s+Q1,
+Kn]R,PPtL]PPY:cPQ-jHPD+_jKn]I)!7q%$!0dD9rr;qNs8N.Ss8W(P#QKL3s+ULQL$ntk~>
+nG`NoF8l4>ErgpnrcA)=rGr5DF*%A&s8R0=rrR7oF8c.=Erl;nr;R+Vs)\5?F*%B]F8u2[!<;h8
+qu6_=K6-qis)\5?!-A/>s)\2>rGr,AF*%A&rr3#GKDb`QUAo:Us)\/=!-A)<%s.blF8u8]s)W8]
+F*%B]KDkfMKDPTSKE$T(K6),6F*%9Z!7:Ua!/(8lrr;q<s8N.As8W(>#QJjds)\5?F70'Y~>
+nG`OKb5VG@aoTlhrlY6?rQ5BFb0'b,s8U7?rrU?ib5MA?aoVOhr;R,Ns2tBAb0'bab5_F_!<;i:
+qu6`?d)u7cs2tBA!6Y<@s2t?@rQ59Cb0'b,rr3#dd/<nIh#GO>s2t<?!6Y6>&'Fppb5_Las2rLa
+b0'bad/EtEd/*bKd/VJmd)sN2b0'Y^!:B[+!7:_frr;r>s8N/Cs8W)@#QMrhs2tBAb3o:[~>
+nG`O$L&V,PK`RD;re:@Os+LUUL&Zj\rVlkOrVlqQPD/u8s+LLRPPkFfPQ-@:s+Q1,s+ULOK`h@/
+s+UFOs+U@M!elhlqu?\Ms8N(Qrr<"Prr;qN"TO10s+UIP!S3J4rr]G(Kn]F(!/:@N%u(%;L&_1,
+s+Q1,Kn]R,PPtL]PPY:bPQ-jHPD+_jL&:lMf)::(s+Q[9L&V,NL&_/SL&_2PKa7X3L&Zl,s+Tn@
+J,~>
+nG`NoF8l4>ErgpnrcA)=s)S>CF8p<&rVlk=rVlq?K6."ks)S5@KDb`VKE$#ms)W8]s)\5=Es)G`
+s)\/=s)\);!cs!8qu?\;s8N(?rr<">rr;q<"TNOas)\2>!RQJsrr]"qF*%6Y!-A)<%s.blF8u8]
+s)W8]F*%B]KDkfMKDPTRKE$T(K6),6F8Pt;d/A"es)WhlF8l4<F8u7AF8u:>EsM_dF8p=]s)[W.
+J,~>
+nG`OKb5VG@aoTlhrlY6?s2kKEb5]W,rVll?rVlrAd)u=es2kBBd/<nNd/V8gs2rLas2tB?aoh[d
+s2t<?s2t6=!m8m4qu?]=s8N)Arr<#@rr;r>"TQWes2t?@!U\83rr_'Vb0'V]!6Y6>&'Fppb5_La
+s2rLab0'bad/EtEd/*bJd/VJmd)sN2b5;2=mJY0/s2r^fb5VG>b5_JCb5_M@ap7shb5]Was2sd0
+J,~>
+nG`O$L&V,PK`mV>L&Zl+s8RcUs+UK,L&M#OL&M#QKp.5hs8RcRs-*B\!gEY<rr3C\s8RfQs+UK,
+s+UK,rVunOqu6_OPD/o6s+ULQ!/:FPs+UIPrIkCSKn]P\rr3#MPPkF_Y5a30qu6YMr;R:]s+Q1,
+s+UK,L&Zj\s8S;]rrA8Zrs4hgPQ-i#L&Zl(rrCXKK`_:.PQ$:8s8@ZOrrRoSs8I]Ws+Q1,L&_1,
+mf.e~>
+nG`NoF8l4>Es.-qF8p=\s8R-Cs)\3]F8c+=F8c+?F+\Q4s8R-@s+C7L!e^Morr3CJs8R0?s)\3]
+s)\3]rVun=qu6_=K6-qis)\5?!-A/>s)\2>rGr,AF*%A&rr3#GKDb`OUAo:Uqu6Y;r;R:Ks)W8]
+s)\3]F8p<&s8R`Mrr@]Jrs48WKE$RFF8p=YrrCFEEruA_KDorks8@$=rrR9As8I'Es)W8]F8u8]
+mf.e~>
+nG`OKb5VG@aop)kb5]W`s8U4Es2tAab5M>?b5M>Ab0\<0s8U4Bs3U]D!mptirr3DLs8U7As2tAa
+s2tAarVuo?qu6`?d)u7cs2tBA!6Y<@s2t?@rQ59Cb0'b,rr3#dd/<nGh#GO>qu6Z=r;R;Ms2rLa
+s2tAab5]W,s8UIErrCFBrs7!Od/VJ8b5]W]rrDHbao_Ucd/M2es8C+?rrU(a)Cs8L.Gs2rLab5_La
+mf.e~>
+nG`O$L&V,PK`[J<L&CuNK`qF0s+Q1*rr@cOrrRn<L&M&OK`V4;r;Qh^s+UIP%#+`]L&_1,s+UK,
+s+UFOs+U@M!elhlqu?\Ms8N(Qrr<"Prr;qN"TO10s+UIP!S3J4rr]G(Kn]4"%u(%;L&_1,s+Q1,
+Kn]R,PPtL]PPY:bPQ-jHPD+_jL&:lMf)::(s+Q[9L&V,PKa.R2s8RfQs8I]Ws+Q1,L&_1,mf.e~>
+nG`NoF8l4>Erq!oF8Z(<Es2Mas)W8[rr(a)-=rrR7oF8c.=Erl;nr;QhNs)\2>%!2IKF8u8]s)\3]
+s)\/=s)\);!cs!8qu?\;s8N(?rr<">rr;q<"TNOas)\2>!RQJsrr]"qF*%$S%s.blF8u8]s)W8]
+F*%B]KDkfMKDPTRKE$T(K6),6F8Pt;d/A"es)WhlF8l4>EsDYcs8R0?s8I'Es)W8]F8u8]mf.e~>
+nG`OKb5VG@ao]rib5D;>aoqaes2rL_rrC4?rrU?ib5MA?aoVOhr;QiFs2t?@%*JVMb5_Las2tAa
+s2t<?s2t6=!m8m4qu?]=s8N)Arr<#@rr;r>"TQWes2t?@!U\83rr_'Vb0'DW&'Fppb5_Las2rLa
+b0'bad/EtEd/*bJd/VJmd)sN2b5;2=mJY0/s2r^fb5VG(a)ap.mgs8U7As8L.Gs2rLab5_Lamf.e~>
+nG`O$L&V,PK`[J<L&:lRL&Zl,Kn]L*!/:CO!elhlrVunO!WSA]rrSDaL&V)\L&_1,s8RfQL&Zl,
+L&M&OL&:lOKp.5fs8RfQrr@cPs8RfPs8@WSs+Q1,L&V)Qes$%3"0VZXL%YHVL&Zj\s8RfQKn]P\
+L&_1:rVlk]qYphbs-*JHKn]P\qu6ZIrIk=QKp2Lirr<"P#60DWs+ULQre:CP"blu1s8Rf@s*t~>
+nG`NoF8l4>Erq!oF8Pt@F8p=]F*%<[!-A,=!cs!8rVun=!WRfMrrRiQF8l1JF8u8]s8R0?F8p=]
+F8c.=F8Pt=F+\Q2s8R0?rr@->s8R0>s8@!As)W8]F8l1?d"D8r"/>g:F7oPDF8p<&s8R0?F*%A&
+F8u8mrVlkMqYphRs+C?(F*%A&qu6ZCrGr&?F+aI5rr<">#6/cEs)\5?rcA,>"`s]bs8R0.s*t~>
+nG`OKb5VG@ao]rib5;2Bb5]Wab0'\_!6Y9?!m8m4rVuo?!WUOErrURIb5VDLb5_Las8U7Ab5]Wa
+b5MA?b5;2?b0\<.s8U7ArrC4@s8U7@s8C(Cs2rLab5VDAmEke2"5Nq!b4YcFb5]W,s8U7Ab0'b,
+b5_LgrVllEqYpiJs3Uemb0'b,qu6Z`rQ53Ab0^.1rr<#@#62jGs2tBArlY9@"j6kfs8U70s*t~>
+p]#dES,i?aJ,~>
+p]#dES,i?aJ,~>
+p]#dES,i?aJ,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4<TETKr2KbWh#Dm~>
+o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4<TETKr2KbWh#Dm~>
+o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4<TETKr2KbWh#Dm~>
+pAY0R<W2suEp<T)j)XYhs&K$t!TS4irr=)<!!((9s8V-ArrC+=s8T+err`=^s/H(ls8Q*krr[9A
+<TEWL!35qs!-6lpJ,~>
+pAY0R<W2suEp<T)j)XYhs&K$t!TS4irr=)<!!((9s8V-ArrC+=s8T+err`=^s/H(ls8Q*krr[9A
+<TEWL!35qs!-6lpJ,~>
+pAY0R<W2suEp<T)j)XYhs&K$t!TS4irr=)<!!((9s8V-ArrC+=s8T+err`=^s/H(ls8Q*krr[9A
+<TEWL!35qs!-6lpJ,~>
+pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[
+n,EEg!8%7$~>
+pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[
+n,EEg!8%7$~>
+pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[
+n,EEg!8%7$~>
+pAY-nEr>qDEo[2[ElS0?<HA*=(33Dqj5Y1#<HA,>WrN+!<HA-"ElV1#qu?[rrVunts8N@b<E6&>
+*KF."q>WDSWrN+ZElV1?j&I*?<TF,><E5(ZWiD(ZWrN*Z<H@."s,L*>j)R-[<N?(>j8]."<N?)Z
+ElV1?qYpb[!'1'>!36%u%rt[Ms8V+Z<B4(Zs)M+[j8Aogj&H(><TF,><E8)ZElW3#j8AoXWW;ts
+s)J7&<N9&>rr3ML<E7*>s2S,[a8b1?<E8)Qs*t~>
+pAY-nEr>qDEo[2[ElS0?<HA*=(33Dqj5Y1#<HA,>WrN+!<HA-"ElV1#qu?[rrVunts8N@b<E6&>
+*KF."q>WDSWrN+ZElV1?j&I*?<TF,><E5(ZWiD(ZWrN*Z<H@."s,L*>j)R-[<N?(>j8]."<N?)Z
+ElV1?qYpb[!'1'>!36%u%rt[Ms8V+Z<B4(Zs)M+[j8Aogj&H(><TF,><E8)ZElW3#j8AoXWW;ts
+s)J7&<N9&>rr3ML<E7*>s2S,[a8b1?<E8)Qs*t~>
+pAY-nEr>qDEo[2[ElS0?<HA*=(33Dqj5Y1#<HA,>WrN+!<HA-"ElV1#qu?[rrVunts8N@b<E6&>
+*KF."q>WDSWrN+ZElV1?j&I*?<TF,><E5(ZWiD(ZWrN*Z<H@."s,L*>j)R-[<N?(>j8]."<N?)Z
+ElV1?qYpb[!'1'>!36%u%rt[Ms8V+Z<B4(Zs)M+[j8Aogj&H(><TF,><E8)ZElW3#j8AoXWW;ts
+s)J7&<N9&>rr3ML<E7*>s2S,[a8b1?<E8)Qs*t~>
+pAY+mrW";dWrE(!s/H(!!!$">ErT,[<?6+[!!#"ZW`<(!WW6$>EiK*>3<6)Ws8Q*ts8Q(,s)K,[
+3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[<TE*[3E6("<<*"Z!<6%!3?;-"NW<'"EcO/?<N?'!WrH'>
+<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%;
+!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~>
+pAY+mrW";dWrE(!s/H(!!!$">ErT,[<?6+[!!#"ZW`<(!WW6$>EiK*>3<6)Ws8Q*ts8Q(,s)K,[
+3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[<TE*[3E6("<<*"Z!<6%!3?;-"NW<'"EcO/?<N?'!WrH'>
+<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%;
+!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~>
+pAY+mrW";dWrE(!s/H(!!!$">ErT,[<?6+[!!#"ZW`<(!WW6$>EiK*>3<6)Ws8Q*ts8Q(,s)K,[
+3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[<TE*[3E6("<<*"Z!<6%!3?;-"NW<'"EcO/?<N?'!WrH'>
+<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%;
+!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~>
+p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[<E9&>ErV."WW9(!*QS*Xs&K$ts&BI,EZL2?
+s/H(Zs&E(qruqHCs8T)!<W<'!s&E)!s)K-?*?F0?*TP0\`rN.><E8&ZNrAtYWW<%u%03EK!6>+"
+<N6%!rrB(rrttfW!-/'[<WC)>a8\/"EZP2[<E7'>N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u
+<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~>
+p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[<E9&>ErV."WW9(!*QS*Xs&K$ts&BI,EZL2?
+s/H(Zs&E(qruqHCs8T)!<W<'!s&E)!s)K-?*?F0?*TP0\`rN.><E8&ZNrAtYWW<%u%03EK!6>+"
+<N6%!rrB(rrttfW!-/'[<WC)>a8\/"EZP2[<E7'>N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u
+<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~>
+p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[<E9&>ErV."WW9(!*QS*Xs&K$ts&BI,EZL2?
+s/H(Zs&E(qruqHCs8T)!<W<'!s&E)!s)K-?*?F0?*TP0\`rN.><E8&ZNrAtYWW<%u%03EK!6>+"
+<N6%!rrB(rrttfW!-/'[<WC)>a8\/"EZP2[<E7'>N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u
+<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~>
+nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTo<W2st<WE(*NZB/#WW<)!<E8nq
+('(B7s/H(ZrrB)!<E9)!<<+%[j8W+Zrr35'!<<(!<N6&srrK,"rr3E-Wi?(!s&E(!!9=(ZWr2l*
+WW;'"!*-$!s/H)!s8>sts8Q(%WW3$!a8,`C!36)!<E9)!!3-%!q>UJq!;uls<=]$/WrE'>rrB)!
+WW<&!Wr;r"j)P-"p&BO~>
+nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTo<W2st<WE(*NZB/#WW<)!<E8nq
+('(B7s/H(ZrrB)!<E9)!<<+%[j8W+Zrr35'!<<(!<N6&srrK,"rr3E-Wi?(!s&E(!!9=(ZWr2l*
+WW;'"!*-$!s/H)!s8>sts8Q(%WW3$!a8,`C!36)!<E9)!!3-%!q>UJq!;uls<=]$/WrE'>rrB)!
+WW<&!Wr;r"j)P-"p&BO~>
+nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTo<W2st<WE(*NZB/#WW<)!<E8nq
+('(B7s/H(ZrrB)!<E9)!<<+%[j8W+Zrr35'!<<(!<N6&srrK,"rr3E-Wi?(!s&E(!!9=(ZWr2l*
+WW;'"!*-$!s/H)!s8>sts8Q(%WW3$!a8,`C!36)!<E9)!!3-%!q>UJq!;uls<=]$/WrE'>rrB)!
+WW<&!Wr;r"j)P-"p&BO~>
+p\u.P<WE*>3<8([WrK(!rrB)!<?9*[WrL+>WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+><E9(!j8U-"
+WW<(Z*HM)X(rrWVEiT/>!<<'!WrH(!s8R*[j8Y."<E9%u%`\Ris#F*"!36'ZWrK(!rr3E-WlG+>
+iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?<Q>*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t
+s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~>
+p\u.P<WE*>3<8([WrK(!rrB)!<?9*[WrL+>WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+><E9(!j8U-"
+WW<(Z*HM)X(rrWVEiT/>!<<'!WrH(!s8R*[j8Y."<E9%u%`\Ris#F*"!36'ZWrK(!rr3E-WlG+>
+iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?<Q>*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t
+s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~>
+p\u.P<WE*>3<8([WrK(!rrB)!<?9*[WrL+>WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+><E9(!j8U-"
+WW<(Z*HM)X(rrWVEiT/>!<<'!WrH(!s8R*[j8Y."<E9%u%`\Ris#F*"!36'ZWrK(!rr3E-WlG+>
+iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?<Q>*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t
+s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~>
+p\t5nr;Zp?WrI,<!!*&t!!92#<W2t"<N6&ts8Q("s/Q%u!lq;@q#:=orW!*BW`<(!*W?'=Wr;u!
+*TR(t!$2"<%EGIKs8N)!s&E)!s5P.!!!90#<W2pt3W/pYs&K$u"02C$!<3!-!36'!!!"&>WW<)!
+!35tss&BR/WW;)Z<HA+>!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[
+WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~>
+p\t5nr;Zp?WrI,<!!*&t!!92#<W2t"<N6&ts8Q("s/Q%u!lq;@q#:=orW!*BW`<(!*W?'=Wr;u!
+*TR(t!$2"<%EGIKs8N)!s&E)!s5P.!!!90#<W2pt3W/pYs&K$u"02C$!<3!-!36'!!!"&>WW<)!
+!35tss&BR/WW;)Z<HA+>!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[
+WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~>
+p\t5nr;Zp?WrI,<!!*&t!!92#<W2t"<N6&ts8Q("s/Q%u!lq;@q#:=orW!*BW`<(!*W?'=Wr;u!
+*TR(t!$2"<%EGIKs8N)!s&E)!s5P.!!!90#<W2pt3W/pYs&K$u"02C$!<3!-!36'!!!"&>WW<)!
+!35tss&BR/WW;)Z<HA+>!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[
+WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~>
+pAY6TWiF,<rs6ZFa2e2[EiS1!rrpHCa8c1[rVuoXs8N8_WoO-Za8#ZHj/T->s8V->s8T+!j8Z+Z
+WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z
+#fluFWiH+!a/]+<s/Q+Zs8N/@WlOr8!?K5Zrrf@Bs8U.6rrC+<<<2(YrtKM6s5W/>s2V/"a8c2"
+WlP/>j/T-Os*t~>
+pAY6TWiF,<rs6ZFa2e2[EiS1!rrpHCa8c1[rVuoXs8N8_WoO-Za8#ZHj/T->s8V->s8T+!j8Z+Z
+WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z
+#fluFWiH+!a/]+<s/Q+Zs8N/@WlOr8!?K5Zrrf@Bs8U.6rrC+<<<2(YrtKM6s5W/>s2V/"a8c2"
+WlP/>j/T-Os*t~>
+pAY6TWiF,<rs6ZFa2e2[EiS1!rrpHCa8c1[rVuoXs8N8_WoO-Za8#ZHj/T->s8V->s8T+!j8Z+Z
+WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z
+#fluFWiH+!a/]+<s/Q+Zs8N/@WlOr8!?K5Zrrf@Bs8U.6rrC+<<<2(YrtKM6s5W/>s2V/"a8c2"
+WlP/>j/T-Os*t~>
+l2LbaWmUhIWW7VMec1.~>
+l2LbaWmUhIWW7VMec1.~>
+l2LbaWmUhIWW7VMec1.~>
+l2Lc)a3jnf`uTa2ec1.~>
+l2Lc)a3jnf`uTa2ec1.~>
+l2Lc)a3jnf`uTa2ec1.~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+%%EndData
+showpage
+%%Trailer
+end
+%%EOF
Added: trunk/thirdparty/emacs/slime/doc/slime-small.pdf
===================================================================
(Binary files differ)
Property changes on: trunk/thirdparty/emacs/slime/doc/slime-small.pdf
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Modified: trunk/thirdparty/emacs/slime/doc/slime.texi
===================================================================
--- trunk/thirdparty/emacs/slime/doc/slime.texi 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/doc/slime.texi 2006-11-30 16:32:54 UTC (rev 2092)
@@ -8,9 +8,26 @@
@end direntry
@c %**end of header
+@set EDITION 2.0
+@c @set UPDATED @today{}
+@set UPDATED @code{$Date: 2006/11/22 06:27:38 $}
+@set TITLE SLIME User Manual
+@settitle @value{TITLE}, version @value{EDITION}
+
+@titlepage
+@title @value{TITLE}
+@titlefont{version @value{EDITION}}
+@sp 2
+@image{slime-small}
+@sp 4
+@subtitle Compiled: @value{UPDATED}
+@end titlepage
+
@c Written by Luke Gorrie.
-@c
+@c
@c This file has been placed in the public domain.
+@c
+@c Modified by Jeff Cunningham.
@macro SLIME
@acronym{SLIME}
@@ -28,37 +45,37 @@
@acronym{CVS}
@end macro
-@c O with a slash through it (norwegian)
-@macro norsko
-@iftex
-@tex
-\\o
-@end tex
-@end iftex
-@ifnottex
-o@c this comment prevents a newline!
-@end ifnottex
+@macro kbditem{key, command}
+@item \key\
+@code{\command\}@*
@end macro
-@macro kbditem{key, command}
+@macro kbdanchor{key, command}
+@anchor{\command\}
@item \key\
@code{\command\}@*
@end macro
-@set EDITION 1.2
-@set UPDATED @code{$Date: 2005/04/18 18:58:12 $}
+@macro kbdindex{key, command}
+@item \key\
+@xref{\command\}.
+@end macro
-@titlepage
-@title SLIME User Manual
-@subtitle The Superior Lisp Interaction Mode for Emacs
-@subtitle @value{EDITION}, @value{UPDATED}
-@author
-@end titlepage
+@macro fcnanchor{name}
+@anchor{\name\}
+@item M-x
+@code{\name\}@*
+@end macro
+@macro fcnindex{name}
+@item \name\
+@xref{\name\}.
+@end macro
+
@c @setchapternewpage off
-
@contents
+@c -----------------------
@node Top, Introduction, (dir), (dir)
@ifinfo
@@ -69,104 +86,27 @@
@end ifinfo
@menu
-* Introduction::
+* Introduction::
* Getting started::
-* slime-mode::
+* slime-mode::
* REPL::
* Debugger::
* Extras::
* Customization::
+* Tips and Tricks::
* Credits::
-
-@detailmenu
- --- The Detailed Node Listing ---
-
-Getting started
-
-* Platforms::
-* Downloading::
-* Installation::
-* Running::
-
-Downloading SLIME
-
-* CVS::
-* CVS Incantations::
-
-Downloading from CVS
-
-* CVS Incantations::
-
-@code{slime-mode}
-
-* User-interface conventions::
-* Commands::
-* Semantic indentation::
-* Reader conditionals::
-
-User-interface conventions
-
-* Temporary buffers::
-* Key bindings::
-* inferior-lisp::
-* Multithreading::
-
-Commands
-
-* Compilation::
-* Finding definitions::
-* Lisp Evaluation::
-* Documentation::
-* Programming Helpers::
-* Recovery::
-* Cross-reference::
-* Inspector::
-* Profiling::
-
-REPL: the ``top level''
-
-* REPL commands::
-* Input Navigation::
-* Shortcuts::
-
-SLDB: the SLIME debugger
-
-* Examining frames::
-* Restarts::
-* Frame Navigation::
-* Miscellaneous::
-
-Extras
-
-* slime-selector::
-* slime-autodoc-mode::
-* Multiple connections::
-* Typeout frames::
-
-Customization
-
-* Emacs-side customization::
-* Lisp-side::
-
-Emacs-side
-
-* Hooks::
-
-Lisp-side (Swank)
-
-* Communication style::
-* Other configurables::
-
-@end detailmenu
+* Index to Key Bindings::
+* Index to Functions::
@end menu
+@c -----------------------
@node Introduction, Getting started, Top, Top
@chapter Introduction
@SLIME{} is the ``Superior Lisp Interaction Mode for Emacs.''
@SLIME{} extends Emacs with new support for interactive programming in
-Common Lisp. The features are centred around @code{slime-mode}, an Emacs
+Common Lisp. The features are centered around @code{slime-mode}, an Emacs
minor-mode that complements the standard @code{lisp-mode}. While
@code{lisp-mode} supports editing Lisp source files, @code{slime-mode}
adds support for interacting with a running Common Lisp process for
@@ -187,6 +127,7 @@
well-defined interface and implemented separately for each Lisp
implementation. This makes @SLIME{} readily portable.
+@c -----------------------
@node Getting started, slime-mode, Introduction, Top
@chapter Getting started
@@ -199,6 +140,7 @@
* Running::
@end menu
+@c -----------------------
@node Platforms, Downloading, Getting started, Getting started
@section Supported Platforms
@@ -214,8 +156,7 @@
@item
CMU Common Lisp (@acronym{CMUCL}), 18e or newer
@item
-Steel Bank Common Lisp (@acronym{SBCL}), from version 0.8.15 to 0.8.21
-(newer versions may or may not work)
+Steel Bank Common Lisp (@acronym{SBCL}), latest official release
@item
OpenMCL, version 0.14.3
@item
@@ -226,6 +167,10 @@
@acronym{CLISP}, version 2.33.2 or newer
@item
Armed Bear Common Lisp (@acronym{ABCL})
+@item
+Corman Common Lisp (@acronym{CCL}), version 2.51 or newer with the patches from @url{http://www.grumblesmurf.org/lisp/corman-patches})
+@item
+Scieneer Common Lisp (@acronym{SCL}), version 1.2.7 or newer
@end itemize
Most features work uniformly across implementations, but some are
@@ -233,6 +178,7 @@
compiler-note annotations, @acronym{XREF} support, and fancy debugger
commands (like ``restart frame'').
+@c -----------------------
@node Downloading, Installation, Platforms, Getting started
@section Downloading SLIME
@@ -250,6 +196,7 @@
* CVS Incantations::
@end menu
+@c -----------------------
@node CVS, CVS Incantations, Downloading, Downloading
@subsection Downloading from CVS
@@ -275,6 +222,7 @@
* CVS Incantations::
@end menu
+@c -----------------------
@node CVS Incantations, , CVS, Downloading
@subsection CVS incantations
@@ -306,6 +254,7 @@
cvs diff -rHEAD ChangeLog # or: -rFAIRLY-STABLE
@end example
+@c -----------------------
@node Installation, Running, Downloading, Getting started
@section Installation
@@ -330,6 +279,7 @@
the keymap for Lisp source files that may be confusing and may not
work correctly for a Lisp process started by @SLIME{}.
+@c -----------------------
@node Running, , Installation, Getting started
@section Running SLIME
@@ -341,6 +291,13 @@
At this point @SLIME{} is up and running and you can start exploring.
+You can restart the @code{inferior-lisp} process using the function:
+@table @kbd
+@fcnanchor{slime-restart-inferior-lisp}
+@end table
+
+
+@c -----------------------
@node slime-mode, REPL, Getting started, Top
@chapter @code{slime-mode}
@@ -355,6 +312,7 @@
* Reader conditionals::
@end menu
+@c -----------------------
@node User-interface conventions, Commands, slime-mode, slime-mode
@section User-interface conventions
@@ -364,12 +322,13 @@
@menu
* Temporary buffers::
-* Key bindings::
+* About key bindings::
* inferior-lisp::
* Multithreading::
@end menu
-@node Temporary buffers, Key bindings, User-interface conventions, User-interface conventions
+@c -----------------------
+@node Temporary buffers, About key bindings, User-interface conventions, User-interface conventions
@subsection Temporary buffers
Some @SLIME{} commands create temporary buffers to display their
@@ -394,8 +353,9 @@
@SLIME{} commands available for describing symbols, looking up
function definitions, and so on.
-@node Key bindings, inferior-lisp, Temporary buffers, User-interface conventions
-@subsection Key bindings
+@c -----------------------
+@node About key bindings, inferior-lisp, Temporary buffers, User-interface conventions
+@subsection About key bindings
In general we try to make our key bindings fit with the overall Emacs
style. We also have the following somewhat unusual convention of our
@@ -415,7 +375,16 @@
C-h} will actually list the bindings for all documentation commands.
This feature is just a bit too useful to clobber!
-@node inferior-lisp, Multithreading, Key bindings, User-interface conventions
+You can assign or change default key bindings using the @code{global-set-key}
+function in your @file{~/.emacs} file like this:
+@example
+(global-set-key "\C-cs" 'slime-selector)
+@end example
+@noindent
+which binds @kbd{C-c s} to the function @code{global-set-key}.
+
+@c -----------------------
+@node inferior-lisp, Multithreading, About key bindings, User-interface conventions
@subsection @code{*inferior-lisp*} buffer
@SLIME{} internally uses the @code{inferior-lisp} package to start
@@ -442,6 +411,7 @@
doesn't belong to @SLIME{}, and you should probably lookup our
equivalent.
+@c -----------------------
@node Multithreading, , inferior-lisp, User-interface conventions
@subsection Multithreading
@@ -468,266 +438,465 @@
swank:*default-worker-thread-bindings*).
@end example
+@c -----------------------
@node Commands, Semantic indentation, User-interface conventions, slime-mode
@section Commands
+@acronym{SLIME} commands are divided into the following general
+categories: @strong{Programming, Compilation, Evaluation, Recovery,
+Inspector, and Profiling}, discussed in separate sections below. There
+are also comprehensive indices to commands by function (@pxref{Index
+to Functions}) and by function (@pxref{Index to Key Bindings}).
+
@menu
+* Programming::
* Compilation::
-* Finding definitions::
-* Lisp Evaluation::
-* Documentation::
-* Programming Helpers::
+* Evaluation::
* Recovery::
-* Cross-reference::
* Inspector::
* Profiling::
+* Other::
@end menu
-@node Compilation, Finding definitions, Commands, Commands
-@subsection Compilation commands
+@c -----------------------
+@node Programming, Compilation, , Commands
+@subsection Programming commands
-@SLIME{} has fancy commands for compiling functions, files, and
-packages. The fancy part is that notes and warnings offered by the
-Lisp compiler are intercepted and annotated directly onto the
-corresponding expressions in the Lisp source buffer. (Give it a try to
-see what this means.)
+Programming commands are divided into the following categories:
+@strong{Completion, Documentation, Coss-reference, Finding
+definitions, Macro-expansion, and Disassembly}, discussed in
+separate sections below.
-@table @kbd
+@menu
+* Completion::
+* Closure::
+* Indentation::
+* Documentation::
+* Cross-reference::
+* Finding definitions::
+* Macro-expansion::
+* Disassembly::
+@end menu
-@kbditem{C-c C-k, slime-compile-and-load-file}
-Compile and load the current buffer's source file.
+@c -----------------------
+@node Completion, Closure, , Programming
+@subsubsection Completion commands
-@kbditem{C-c M-k, slime-compile-file}
-Compile (but don't load) the current buffer's source file.
+Completion commands are used to complete a symbol or form based on
+what is already present at point. Classical completion assumes an
+exact prefix and gives choices only where branches may occur. Fuzzy
+completion tries harder.
-@kbditem{C-c C-c, slime-compile-defun}
-Compile the top-level form at point.
+@table @kbd
+@anchor{slime-complete-symbol}
+@itemx M-TAB
+@item C-c C-i
+@item C-M-i
+@code{slime-complete-symbol}@*
+Complete the symbol at point. Note that three styles of completion are
+available in @SLIME{}, and the default differs from normal Emacs
+completion (@pxref{slime-complete-symbol-function}).
+@xref{Emacs-side customization}.
-@end table
+@kbdanchor{C-c C-s, slime-complete-form}
+Looks up and inserts into the current buffer the argument list for the
+function at point, if there is one. More generally, the command
+completes an incomplete form with a template for the missing arguments.
+There is special code for discovering extra keywords of generic
+functions and for handling @code{make-instance} and
+@code{defmethod}. Examples:
-The annotations are indicated as underlining on source forms. The
-compiler message associated with an annotation can be read either by
-placing the mouse over the text or with the selection commands below.
+@example
+(subseq "abc" <C-c C-s>
+ --inserts--> start [end])
+(find 17 <C-c C-s>
+ --inserts--> sequence :from-end from-end :test test
+ :test-not test-not :start start :end end
+ :key key)
+(find 17 '(17 18 19) :test #'= <C-c C-s>
+ --inserts--> :from-end from-end
+ :test-not test-not :start start :end end
+ :key key)
+(defclass foo () ((bar :initarg :bar)))
+(defmethod print-object <C-c C-s>
+ --inserts--> (object stream)
+ body...)
+(defmethod initialize-instance :after ((object foo) &key blub))
+(make-instance 'foo <C-c C-s>
+ --inserts--> :bar bar :blub blub initargs...)
+@end example
-@table @kbd
+@kbdanchor{C-c M-i, slime-fuzzy-complete-symbol}
+Presents a list of likely completions to choose from for an
+abbreviation at point. This is a third completion method and it is
+very different from the more traditional completion to which
+@command{slime-complete-symbol} defaults. It attempts to complete a
+symbol all at once, instead of in pieces. For example, ``mvb'' will
+find ``@code{multiple-value-bind}'' and ``norm-df'' will find
+``@code{least-positive-normalized-double-float}''. This can also be
+selected as the method of completion used for
+@code{slime-complete-symbol}.
-@item M-n
-@itemx M-p
-@code{slime-next-note, slime-previous-note}@*
-These commands move the point between compiler notes and display the new note.
+@fcnanchor{slime-fuzzy-completions-mode}
+@fcnanchor{slime-fuzzy-abort}
+@end table
-@kbditem{C-c M-c, slime-remove-notes}
-Remove all annotations from the buffer.
-@end table
+@c -----------------------
+@node Closure, Indentation, Completion, Programming
+@subsubsection Closure commands
-@node Finding definitions, Lisp Evaluation, Compilation, Commands
-@subsection Finding definitions (``Meta-Point'').
+Closure commands are used to fill in missing parenthesis.
-The familiar @kbd{M-.} command is provided. For generic functions this
-command finds all methods, and with some systems it does other fancy
-things (like tracing structure accessors to their @code{DEFSTRUCT}
-definition).
-
@table @kbd
+@kbdanchor{C-c C-q, slime-close-parens-at-point}
+Closes parentheses at point to complete the top-level-form by inserting ')'
+characters at until @code{beginning-of-defun} and @code{end-of-defun}
+execute without errors, or @code{slime-close-parens-limit} is exceeded.
-@kbditem{M-., slime-edit-definition}
-Go to the definition of the symbol at point.
+@kbdanchor{C-], slime-close-all-sexp}
+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.
-@item M-,
-@code{slime-pop-find-definition-stack}
-Go back from a definition found with @kbd{M-.}. This gives multi-level
-backtracking when @kbd{M-.} has been used several times.
-
+If @code{REGION} is true, operate on the region. Otherwise operate on
+the top-level sexp before point.
@end table
-@node Lisp Evaluation, Documentation, Finding definitions, Commands
-@subsection Lisp Evaluation
-These commands each evaluate a Lisp expression in a different way. By
-default they show their results in a message, but a prefix argument
-causes the results to be printed in the @REPL{} instead.
+@c -----------------------
+@node Indentation, Documentation, Closure, Programming
+@subsubsection Indentation commands
@table @kbd
+@kbdanchor{C-c M-q, slime-reindent-defun}
+Re-indents the current defun, or refills 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 @code{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.
-@kbditem{C-M-x, slime-eval-defun}
-Evaluate top-level form.
-
-@kbditem{C-x C-e, slime-eval-last-expression}
-Evaluate the expression before point.
-
-@kbditem{C-c C-p, slime-pprint-eval-last-expression}
-Evaluate the expression before point and pretty-print the result.
-
-@kbditem{C-c C-r, slime-eval-region}
-Evaluate the region.
-
-@kbditem{C-c :, slime-interactive-eval}
-Evaluate an expression read from the minibuffer.
-
-@anchor{slime-scratch}
-@item M-x slime-scratch
-Create a @file{*slime-scratch*} buffer. In this
-buffer you can enter Lisp expressions and evaluate them with
-@kbd{C-j}, like in Emacs's @file{*scratch*} buffer.
-
+When given a prefix argument, the text around point will always
+be treated as a paragraph. This is useful for filling docstrings."
@end table
-If `C-M-x' or `C-x C-e' is given a numeric argument, it inserts the
-value into the current buffer at point, rather than displaying it in the
-echo area.
-@node Documentation, Programming Helpers, Lisp Evaluation, Commands
-@subsection Documentation
+@c -----------------------
+@node Documentation, Cross-reference, Indentation, Programming
+@subsubsection Documentation commands
@SLIME{}'s online documentation commands follow the example of Emacs
Lisp. The commands all share the common prefix @kbd{C-c C-d} and allow
-the final key to be modified or unmodified (@xref{Key bindings}.)
+the final key to be modified or unmodified (@pxref{About key bindings}.)
@table @kbd
-@kbditem{C-c C-d d, slime-describe-symbol}
+@kbdanchor{SPC, slime-space}
+The space key inserts a space, but also looks up and displays the
+argument list for the function at point, if there is one.
+
+@kbdanchor{C-c C-d d, slime-describe-symbol}
Describe the symbol at point.
-@kbditem{C-c C-d a, slime-apropos}
-Apropos search. Search Lisp symbol names for a substring match and
-present their documentation strings. By default the external symbols
-of all packages are searched. With a prefix argument you can choose a
+@kbdanchor{C-c C-f, slime-describe-function}
+Describe the function at point.
+
+@kbdanchor{C-c C-d a, slime-apropos}
+Perform an apropos search on Lisp symbol names for a regular expression
+match and display their documentation strings. By default the external
+symbols of all packages are searched. With a prefix argument you can choose a
specific package and whether to include unexported symbols.
-@kbditem{C-c C-d z, slime-apropos-all}
+@kbdanchor{C-c C-d z, slime-apropos-all}
Like @code{slime-apropos} but also includes internal symbols by default.
-@kbditem{C-c C-d p, slime-apropos-package}
+@kbdanchor{C-c C-d p, slime-apropos-package}
Show apropos results of all symbols in a package. This command is for
browsing a package at a high-level. With package-name completion it
also serves as a rudimentary Smalltalk-ish image-browser.
-@kbditem{C-c C-d h, slime-hyperspec-lookup}
+@kbdanchor{C-c C-d h, slime-hyperspec-lookup}
Lookup the symbol at point in the @cite{Common Lisp Hyperspec}. This
uses the familiar @file{hyperspec.el} to show the appropriate section
in a web browser. The Hyperspec is found either on the Web or in
@code{common-lisp-hyperspec-root}, and the browser is selected by
@code{browse-url-browser-function}.
-@kbditem{C-c C-d ~, common-lisp-hyperspec-format}
-Lookup a format character in the @cite{Common Lisp Hyperspec}.
+Note: this is one case where @kbd{C-c C-d h} is @emph{not} the same as
+@kbd{C-c C-d C-h}.
+
+@kbdanchor{C-c C-d ~, common-lisp-hyperspec-format}
+Lookup a @emph{format character} in the @cite{Common Lisp Hyperspec}.
@end table
-@node Programming Helpers, Recovery, Documentation, Commands
-@subsection Programming Helpers
+@c -----------------------
+@node Cross-reference, Finding definitions, Documentation, Programming
+@subsubsection Cross-reference commands
+
+@SLIME{}'s cross-reference commands are based on the support provided
+by the Lisp system, which varies widely between Lisps. For systems
+with no builtin @acronym{XREF} support @SLIME{} queries a portable
+@acronym{XREF} package, which is taken from the @cite{CMU AI
+Repository} and bundled with @SLIME{}.
+
+Each command operates on the symbol at point, or prompts if there is
+none. With a prefix argument they always prompt. You can either enter
+the key bindings as shown here or with the control modified on the
+last key, @xref{About key bindings}.
+
@table @kbd
-@kbditem{M-TAB, slime-complete-symbol}
-Complete the symbol at point. Note that three styles of completion are
-available in @SLIME{}, and the default differs from normal Emacs
-completion. @xref{Emacs-side customization}.
+@kbdanchor{C-c C-w c, slime-who-calls}
+Show function callers.
-@anchor{slime-fuzzy-complete-symbol}
-@kbditem{C-c M-i, slime-fuzzy-complete-symbol}
-Presents a list of likely completions to choose from for an
-abbreviation at point. This is a third completion method and it is
-very different from the more traditional completion to which
-@command{slime-complete-symbol} defaults. It attempts to complete a
-symbol all at once, instead of in pieces. For example, ``mvb'' will
-find ``@code{multiple-value-bind}'' and ``norm-df'' will find
-``@code{least-positive-normalized-double-float}''. This can also be
-selected as the method of completion used for
-@code{slime-complete-symbol}.
+@kbdanchor{C-c C-w r, slime-who-references}
+Show references to global variable.
-@kbditem{SPC, slime-space}
-The space key inserts a space and also looks up and displays the
-argument list for the function at point, if there is one.
+@kbdanchor{C-c C-w b, slime-who-binds}
+Show bindings of a global variable.
-@kbditem{C-c C-s, slime-insert-arglist}
-Looks up and inserts into the current buffer the argument list for the
-function at point, if there is one.
+@kbdanchor{C-c C-w s, slime-who-sets}
+Show assignments to a global variable.
-@kbditem{C-c C-m, slime-macroexpand-1}
+@kbdanchor{C-c C-w m, slime-who-macroexpands}
+Show expansions of a macro.
+
+@fcnanchor{slime-who-specializes}
+Show all known methods specialized on a class.
+
+@fcnanchor{slime-goto-xref}
+Goto the cross-referenced location at point.
+
+@end table
+
+There are also ``List callers/callees'' commands. These operate by
+rummaging through function objects on the heap at a low-level to
+discover the call graph. They are only available with some Lisp
+systems, and are most useful as a fallback when precise @acronym{XREF}
+information is unavailable.
+
+@table @kbd
+@kbdanchor{C-c <, slime-list-callers}
+List callers of a function.
+
+@kbdanchor{C-c >, slime-list-callees}
+List callees of a function.
+
+@fcnanchor{slime-calls-who}
+Show all known functions called by the function SYMBOL.
+@end table
+
+
+
+@c -----------------------
+@node Finding definitions, Macro-expansion, Cross-reference, Programming
+@subsubsection Finding definitions (``Meta-Point'' commands).
+
+The familiar @kbd{M-.} command is provided. For generic functions this
+command finds all methods, and with some systems it does other fancy
+things (like tracing structure accessors to their @code{DEFSTRUCT}
+definition).
+
+@table @kbd
+
+@kbdanchor{M-., slime-edit-definition}
+Go to the definition of the symbol at point.
+
+@anchor{slime-pop-find-definition-stack}
+@item M-,
+@code{slime-pop-find-definition-stack}
+Go back to the point where @kbd{M-.} was invoked. This gives multi-level
+backtracking when @kbd{M-.} has been used several times.
+
+@kbdanchor{C-x 4 ., slime-edit-definition-other-window}
+Like @code{slime-edit-definition} but switchs to the other window to edit the definition in.
+
+@kbdanchor{C-x 5 ., slime-edit-definition-other-frame}
+Like @code{slime-edit-definition} but opens another frame to edit the definition in.
+
+@fcnanchor{slime-edit-definition-with-etags}
+Use an ETAGS table to find definition at point.
+@end table
+
+@c -----------------------
+@node Macro-expansion, Disassembly, Finding definitions, Programming
+@subsubsection Macro-expansion commands
+
+@table @kbd
+@anchor{slime-macroexpand-1}
+@item C-c C-m
+@itemx C-c RET
+@code{slime-macroexpand-1}@*
Macroexpand the expression at point once. If invoked with a prefix
argument, use macroexpand instead of macroexpand-1.
-@kbditem{C-c M-m, slime-macroexpand-all}
+@kbdanchor{C-c M-m, slime-macroexpand-all}
Fully macroexpand the expression at point.
-@kbditem{C-c C-t, slime-toggle-trace-fdefinition}
+@kbdanchor{C-c C-t, slime-toggle-trace-fdefinition}
Toggle tracing of the function at point. If invoked with a prefix
argument, read additional information, like which particular method
should be traced.
-@kbditem{C-c M-d, slime-disassemble-symbol}
-Disassemble the function definition of the symbol at point.
+@fcnanchor{slime-untrace-all}
+Untrace all functions.
@end table
-@node Recovery, Cross-reference, Programming Helpers, Commands
-@subsection Abort/Recovery
+For additional minor-mode commands and discussion,
+@pxref{slime-macroexpansion-minor-mode}.
+
+@c -----------------------
+@node Disassembly, , Macro-expansion, Programming
+@subsubsection Disassembly commands
+
@table @kbd
-@kbditem{C-c C-b, slime-interrupt}
-Interrupt Lisp (send @code{SIGINT}).
+@kbdanchor{C-c M-d, slime-disassemble-symbol}
+Disassemble the function definition of the symbol at point.
+@end table
-@kbditem{C-c ~, slime-sync-package-and-default-directory}
-Synchronize the current package and working directory from Emacs to
-Lisp.
+@c -----------------------
+@c -----------------------
+@node Compilation, Evaluation, Programming, Commands
+@subsection Compilation commands
-@kbditem{C-c M-p, slime-repl-set-package}
-Set the current package of the @acronym{REPL}.
+@SLIME{} has fancy commands for compiling functions, files, and
+packages. The fancy part is that notes and warnings offered by the
+Lisp compiler are intercepted and annotated directly onto the
+corresponding expressions in the Lisp source buffer. (Give it a try to
+see what this means.)
+@table @kbd
+@kbdanchor{C-c C-c, slime-compile-defun}
+Compile the top-level form at point.
+@cindex compiling functions
+
+@kbdanchor{C-c C-y, slime-call-defun}
+Insert a call to the function defined around point into the REPL.
+
+@kbdanchor{C-c C-k, slime-compile-and-load-file}
+Compile and load the current buffer's source file.
+
+@kbdanchor{C-c M-k, slime-compile-file}
+Compile (but don't load) the current buffer's source file.
+
+@kbdanchor{C-c C-l, slime-load-file}
+Load a source file and compile if necessary, without loading into a buffer..
+
+@kbdanchor{C-c C-z, slime-switch-to-output-buffer}
+Select the output buffer, preferably in a different window.
+
+@fcnanchor{slime-compile-region}
+Compile region at point.
+
+@fcnanchor{slime-compiler-macroexpand}
+Display the compiler-macro expansion of sexp at point.
+
+@fcnanchor{slime-compiler-macroexpand-1}
+Display the compiler-macro expansion of sexp at point.
+
+@fcnanchor{slime-compiler-notes-default-action-or-show-details}
+Invoke the action at point, or show details.
+
+@fcnanchor{slime-compiler-notes-default-action-or-show-details/mouse}
+Invoke the action pointed at by the mouse, or show details.
+
+@fcnanchor{slime-compiler-notes-mode}
+
+@fcnanchor{slime-compiler-notes-quit}
+
+@fcnanchor{slime-compiler-notes-show-details}
@end table
-@node Cross-reference, Inspector, Recovery, Commands
-@subsection Cross-reference
+The annotations are indicated as underlining on source forms. The
+compiler message associated with an annotation can be read either by
+placing the mouse over the text or with the selection commands below.
-@SLIME{}'s cross-reference commands are based on the support provided
-by the Lisp system, which varies widely between Lisps. For systems
-with no builtin @acronym{XREF} support @SLIME{} queries a portable
-@acronym{XREF} package, which is taken from the @cite{CMU AI
-Repository} and bundled with @SLIME{}.
+@table @kbd
+@kbdanchor{M-n, slime-next-note}
+Move the point to the next compiler note and displays the note.
-Each command operates on the symbol at point, or prompts if there is
-none. With a prefix argument they always prompt. You can either enter
-the key bindings as shown here or with the control modified on the
-last key, @xref{Key bindings}.
+@kbdanchor{M-p, slime-previous-note}
+Move the point to the previous compiler note and displays the note.
+@kbdanchor{C-c M-c, slime-remove-notes}
+Remove all annotations from the buffer.
+@end table
+
+@c -----------------------
+@node Evaluation, Recovery, Compilation, Commands
+@subsection Evaluation commands
+
+These commands each evaluate a Lisp expression in a different way. By
+default they show their results in a message, but a prefix argument
+causes the results to be printed in the @REPL{} instead.
+
@table @kbd
-@kbditem{C-c C-w c, slime-who-calls}
-Show function callers.
+@kbdanchor{C-M-x, slime-eval-defun}
+Evaluate the current toplevel form.
+Use @code{slime-re-evaluate-defvar} if the from starts with @code{(defvar}.
-@kbditem{C-c C-w r, slime-who-references}
-Show references to global variable.
+@kbdanchor{C-x C-e, slime-eval-last-expression}
+Evaluate the expression before point.
+@end table
-@kbditem{C-c C-w b, slime-who-binds}
-Show bindings of a global variable.
+If @kbd{C-M-x} or @kbd{C-x C-e} is given a numeric argument, it inserts the
+value into the current buffer at point, rather than displaying it in the
+echo area.
-@kbditem{C-c C-w s, slime-who-sets}
-Show assignments to a global variable.
+@table @kbd
+@kbdanchor{C-c C-p, slime-pprint-eval-last-expression}
+Evaluate the expression before point and pretty-print the result.
-@kbditem{C-c C-w m, slime-who-macroexpands}
-Show expansions of a macro.
+@kbdanchor{C-c C-r, slime-eval-region}
+Evaluate the region.
-@item M-x slime-who-specializes
-Show all known methods specialized on a class.
+@kbdanchor{C-x M-e, slime-eval-last-expression-display-output}
+Display output buffer and evaluate the expression preceding point.
+@kbdanchor{C-c :, slime-interactive-eval}
+Evaluate an expression read from the minibuffer.
+
+@kbdanchor{M-x, slime-scratch}
+Create a @file{*slime-scratch*} buffer. In this
+buffer you can enter Lisp expressions and evaluate them with
+@kbd{C-j}, like in Emacs's @file{*scratch*} buffer.
+
+@kbdanchor{C-c E, slime-edit-value}
+Edit the value of a setf-able form in a new buffer @file{*Edit <form>*}.
+The value is inserted into a temporary buffer for editing and then set
+in Lisp when committed with @code{slime-edit-value-commit}.
+
+@kbdanchor{C-c C-u, slime-undefine-function}
+Unbind symbol for function at point.
@end table
-There are also ``List callers/callees'' commands. These operate by
-rummaging through function objects on the heap at a low-level to
-discover the call graph. They are only available with some Lisp
-systems, and are most useful as a fallback when precise @acronym{XREF}
-information is unavailable.
+@c -----------------------
+@node Recovery, Inspector, Evaluation, Commands
+@subsection Abort/Recovery commands
+
@table @kbd
-@kbditem{C-c <, slime-list-callers}
-List callers of a function.
-@kbditem{C-c >, slime-list-callees}
-List callees of a function.
+@kbdanchor{C-c C-b, slime-interrupt}
+Interrupt Lisp (send @code{SIGINT}).
+
+@kbdanchor{C-c ~, slime-sync-package-and-default-directory}
+Synchronize the current package and working directory from Emacs to
+Lisp.
+
+@kbdanchor{C-c M-p, slime-repl-set-package}
+Set the current package of the @acronym{REPL}.
+
@end table
-@node Inspector, Profiling, Cross-reference, Commands
-@subsection Inspector
+@c -----------------------
+@node Inspector, Profiling, Recovery, Commands
+@subsection Inspector commands
The @SLIME{} inspector is a very fancy Emacs-based alternative to the
standard @code{INSPECT} function. The inspector presents objects in
@@ -743,51 +912,70 @@
function in @file{swank-backend.lisp}.
@table @kbd
-@kbditem{C-c I, slime-inspect}
+
+@kbdanchor{C-c I, slime-inspect}
Inspect the value of an expression entered in the minibuffer.
+
@end table
The standard commands available in the inspector are:
@table @kbd
-@kbditem{RET, slime-inspector-operate-on-point}
+@kbdanchor{RET, slime-inspector-operate-on-point}
If point is on a value then recursivly call the inspcetor on that
value. If point is on an action then call that action.
-@kbditem{d, slime-inspector-describe}
+@kbdanchor{d, slime-inspector-describe}
Describe the slot at point.
-@kbditem{l, slime-inspector-pop}
+@kbdanchor{l, slime-inspector-pop}
Go back to the previous object (return from @kbd{RET}).
-@kbditem{n, slime-inspector-next}
+@kbdanchor{n, slime-inspector-next}
The inverse of @kbd{l}. Also bound to @kbd{SPC}.
-@kbditem{q, slime-inspector-quit}
+@kbdanchor{q, slime-inspector-quit}
Dismiss the inspector buffer.
-@kbditem{M-RET, slime-inspector-copy-down} Evaluate the value under
+@kbdanchor{M-RET, slime-inspector-copy-down} Evaluate the value under
point via the REPL (to set `*').
@end table
-@node Profiling, , Inspector, Commands
-@subsection Profiling
+@c -----------------------
+@node Profiling, Other, Inspector, Commands
+@subsection Profiling commands
@table @kbd
-@item M-x slime-toggle-profile-fdefinition
+@fcnanchor{slime-toggle-profile-fdefinition}
Toggle profiling of a function.
-@item M-x slime-profile-package
+@fcnanchor{slime-profile-package}
Profile all functions in a package.
-@item M-x slime-unprofile-all
+@fcnanchor{slime-unprofile-all}
Unprofile all functions.
-@item M-x slime-profile-report
+@fcnanchor{slime-profile-report}
Report profiler data.
-@item M-x slime-profile-reset
+@fcnanchor{slime-profile-reset}
Reset profiler data.
+@fcnanchor{slime-profiled-functions}
+Show list of currently profiled functions.
@end table
+@c -----------------------
+@node Other, , Profiling, Commands
+@subsection Shadowed Commands
+
+@table @kbd
+
+@kbdanchor{C-c C-a, slime-nop}
+This key-binding is shadowed from lisp-inf.
+@kbditem{C-c C-v, slime-nop}
+This key-binding is shadowed from lisp-inf.
+
+@end table
+
+@c -----------------------
@node Semantic indentation, Reader conditionals, Commands, slime-mode
@section Semantic indentation
@@ -820,7 +1008,7 @@
A more subtle issue is that imperfect caching is used for the sake of
performance. @footnote{@emph{Of course} we made sure it was actually too
slow before making the ugly optimization.}
-@c
+
In an ideal world, Lisp would automatically scan every symbol for
indentation changes after each command from Emacs. However, this is too
expensive to do every time. Instead Lisp usually just scans the symbols
@@ -833,6 +1021,7 @@
You can use @kbd{M-x slime-update-indentation} to force all symbols to
be scanned for indentation information.
+@c -----------------------
@node Reader conditionals, , Semantic indentation, slime-mode
@section Reader conditional fontification
@@ -840,6 +1029,7 @@
source buffers and ``grays out'' code that will be skipped for the
current Lisp connection.
+@c -----------------------
@node REPL, Debugger, slime-mode, Top
@chapter REPL: the ``top level''
@@ -866,46 +1056,53 @@
* Shortcuts::
@end menu
+@c -----------------------
@node REPL commands, Input Navigation, REPL, REPL
@section REPL commands
@table @kbd
-@kbditem{RET, slime-repl-return}
+@kbdanchor{RET, slime-repl-return}
Evaluate the current input in Lisp if it is complete. If incomplete,
open a new line and indent. If a prefix argument is given then the
input is evaluated without checking for completeness.
-@kbditem{C-RET, slime-repl-closing-return}
+@kbdanchor{C-RET, slime-repl-closing-return}
Close any unmatched parenthesis and then evaluate the current input in
Lisp. Also bound to @kbd{M-RET}.
-@kbditem{C-j, slime-repl-newline-and-indent}
+@kbdanchor{C-j, slime-repl-newline-and-indent}
Open and indent a new line.
+@c @anchor{slime-interrupt}
@kbditem{C-c C-c, slime-interrupt}
Interrupt the Lisp process with @code{SIGINT}.
-@kbditem{TAB, slime-complete-symbol}
-Complete the symbol at point.
+@kbdanchor{C-c M-g, slime-quit}
+Quit slime.
-@kbditem{C-c C-o, slime-repl-clear-output}
+@kbdanchor{C-c C-o, slime-repl-clear-output}
Remove the output and result of the previous expression from the
buffer.
-@kbditem{C-c C-t, slime-repl-clear-buffer}
+@kbdanchor{C-c C-t, slime-repl-clear-buffer}
Clear the entire buffer, leaving only a prompt.
@end table
+@c -----------------------
@node Input Navigation, Shortcuts, REPL commands, REPL
@section Input navigation
@table @kbd
-@kbditem{C-a, slime-repl-bol}
+@kbdanchor{C-a, slime-repl-bol}
Go to the beginning of the line, but stop at the @REPL{} prompt.
+@anchor{slime-repl-next-input}
+@anchor{slime-repl-next-matching-input}
+@anchor{slime-repl-previous-input}
+@anchor{slime-repl-previous-matching-input}
@item M-n
@itemx M-p
@itemx M-s
@@ -914,11 +1111,15 @@
@code{slime-repl-@{next,previous@}-matching-input}@*
@code{comint}-style input history commands.
+@anchor{slime-repl-next-prompt}
+@anchor{slime-repl-previous-prompt}
@item C-c C-n
@itemx C-c C-p
@code{slime-repl-next-prompt, slime-repl-previous-prompt}@*
Move between the current and previous prompts in the @REPL{} buffer.
+@anchor{slime-repl-beginning-of-defun}
+@anchor{slime-repl-end-of-defun}
@item C-M-a
@itemx C-M-e
@code{slime-repl-beginning-of-defun, slime-repl-end-of-defun}
@@ -928,6 +1129,7 @@
@end table
+@c -----------------------
@comment node-name, next, previous, up
@node Shortcuts, , Input Navigation, REPL
@section Shortcuts
@@ -941,6 +1143,7 @@
currently documented in this manual, but you can use the @code{help}
shortcut to list them interactively.
+@c -----------------------
@node Debugger, Extras, REPL, Top
@chapter SLDB: the SLIME debugger
@@ -960,65 +1163,63 @@
* Miscellaneous::
@end menu
+@c -----------------------
@node Examining frames, Restarts, Debugger, Debugger
@section Examining frames
Commands for examining the stack frame at point.
@table @kbd
-
-@kbditem{t, sldb-toggle-details}
+@kbdanchor{t, sldb-toggle-details}
Toggle display of local variables and @code{CATCH} tags.
-@kbditem{v, sldb-show-source}
+@kbdanchor{v, sldb-show-source}
View the frame's current source expression. The expression is
presented in the Lisp source file's buffer.
-@kbditem{e, sldb-eval-in-frame}
+@kbdanchor{e, sldb-eval-in-frame}
Evaluate an expression in the frame. The expression can refer to the
available local variables in the frame.
-@kbditem{d, sldb-pprint-eval-in-frame}
+@kbdanchor{d, sldb-pprint-eval-in-frame}
Evaluate an expression in the frame and pretty-print the result in a
temporary buffer.
-@kbditem{D, sldb-disassemble}
+@kbdanchor{D, sldb-disassemble}
Disassemble the frame's function. Includes information such as the
instruction pointer within the frame.
-@kbditem{i, sldb-inspect-in-frame}
+@kbdanchor{i, sldb-inspect-in-frame}
Inspect the result of evaluating an expression in the frame.
-
@end table
+@c -----------------------
@node Restarts, Frame Navigation, Examining frames, Debugger
@section Invoking restarts
@table @kbd
-
-@kbditem{a, sldb-abort}
+@kbdanchor{a, sldb-abort}
Invoke the @code{ABORT} restart.
-@kbditem{q, sldb-quit}
+@kbdanchor{q, sldb-quit}
``Quit'' -- @code{THROW} to a tag that the top-level @SLIME{}
request-loop catches.
-@kbditem{c, sldb-continue}
+@kbdanchor{c, sldb-continue}
Invoke the @code{CONTINUE} restart.
@item 0 ... 9
Invoke a restart by number.
-
@end table
Restarts can also be invoked by pressing @kbd{RET} or @kbd{Mouse-2} on
them in the buffer.
+@c -----------------------
@node Frame Navigation, Miscellaneous, Restarts, Debugger
@section Navigating between frames
@table @kbd
-
@item n
@item p
@code{sldb-down, sldb-up}@*
@@ -1031,46 +1232,48 @@
frame and display the details and source code of the next. Sugared
motion makes you see the details and source code for the current frame
only.
-
@end table
+@c -----------------------
@node Miscellaneous, , Frame Navigation, Debugger
@section Miscellaneous Commands
@table @kbd
-
-@kbditem{r, sldb-restart-frame}
+@kbdanchor{r, sldb-restart-frame}
Restart execution of the frame with the same arguments it was
originally called with. (This command is not available in all
implementations.)
-@kbditem{R, sldb-return-from-frame}
+@kbdanchor{R, sldb-return-from-frame}
Return from the frame with a value entered in the minibuffer. (This
command is not available in all implementations.)
-@kbditem{s, sldb-step}
+@kbdanchor{s, sldb-step}
Step to the next expression in the frame. (This command is not
available in all implementations.)
-@kbditem{B, sldb-break-with-default-debugger}
+@kbdanchor{B, sldb-break-with-default-debugger}
Exit @SLDB{} and debug the condition using the Lisp system's default
debugger.
-@kbditem{:, slime-interactive-eval}
+@c @anchor{slime-interactive-eval}
+@kbditem{C-c :, slime-interactive-eval}
Evaluate an expression entered in the minibuffer.
-
@end table
+@c -----------------------
@node Extras, Customization, Debugger, Top
@chapter Extras
@menu
* slime-selector::
* slime-autodoc-mode::
+* slime-macroexpansion-minor-mode::
* Multiple connections::
* Typeout frames::
@end menu
+@c -----------------------
@node slime-selector, slime-autodoc-mode, Extras, Extras
@section @code{slime-selector}
@@ -1093,36 +1296,62 @@
@end table
@code{slime-selector} doesn't have a key binding by default but we
-suggest that you assign it a global one. You can bind @kbd{C-c s} like
-this:
+suggest that you assign it a global one. You can bind it to @kbd{C-c s}
+like this:
@example
(global-set-key "\C-cs" 'slime-selector)
@end example
+@noindent
And then you can switch to the @REPL{} from anywhere with @kbd{C-c s
r}.
The macro @code{def-slime-selector-method} can be used to define new
buffers for @code{slime-selector} to find.
-@node slime-autodoc-mode, Multiple connections, slime-selector, Extras
+@c -----------------------
+@node slime-autodoc-mode, slime-macroexpansion-minor-mode, slime-selector, Extras
@section @code{slime-autodoc-mode}
-@code{slime-autodoc-mode} is an additional minor-mode for
-automatically showing information about symbols near the point. For
-function names the argument list is displayed and for global variables
-we show the value. This is a clone of @code{eldoc-mode} for Emacs
-Lisp.
+@table @kbd
+@kbditem{M-x, slime-autodoc-mode}
+Autodoc mode is an additional minor-mode for automatically showing
+information about symbols near the point. For function names the
+argument list is displayed, and for global variables, the value.
+This is a clone of @code{eldoc-mode} for Emacs Lisp.
+@end table
-The mode can be enabled in the @code{slime-setup} call of your
+The mode can be enabled by default in the @code{slime-setup} call of your
@code{~/.emacs}:
-
@example
(slime-setup :autodoc t)
@end example
-@node Multiple connections, Typeout frames, slime-autodoc-mode, Extras
+@c -----------------------
+@node slime-macroexpansion-minor-mode, Multiple connections, slime-autodoc-mode, Extras
+@section slime-macroexpansion-minor-mode
+
+Within a slime macroexpansion buffer some extra commands are provided
+(these commands are always available but are only bound to keys in a
+macroexpansion buffer).
+
+@table @kbd
+@kbdanchor{C-c C-m, slime-macroexpand-1-inplace}
+Just like slime-macroexpand-1 but the original form is replaced with the expansion.
+
+@c @anchor{slime-macroexpand-1-inplace}
+@kbditem{g, slime-macroexpand-1-inplace}
+The last macroexpansion is performed again, the current contents of
+the macroexpansion buffer are replaced with the new expansion.
+
+@kbdanchor{q, slime-temp-buffer-quit}
+Close the expansion buffer.
+
+@end table
+
+@c -----------------------
+@node Multiple connections, Typeout frames, slime-macroexpansion-minor-mode, Extras
@section Multiple connections
@SLIME{} is able to connect to multiple Lisp processes at the same
@@ -1147,8 +1376,16 @@
the ``connection list'' buffer:
@table @kbd
-@kbditem{C-c C-x c, slime-list-connections}
+@kbdanchor{C-c C-x c, slime-list-connections}
Pop up a buffer listing the established connections.
+
+@kbdanchor{C-c C-x t, slime-list-threads}
+Pop up a buffer listing the current threads.
+
+@fcnanchor{slime-abort-connection}
+Abort the current connection.
+
+@fcnanchor{slime-restart-connection-at-point}
@end table
The buffer displayed by @code{slime-list-connections} gives a one-line
@@ -1160,22 +1397,30 @@
The commands available in the connection-list buffer are:
@table @kbd
-
-@kbditem{RET, slime-goto-connection}
+@kbdanchor{RET, slime-goto-connection}
Pop to the @acronym{REPL} buffer of the connection at point.
-@kbditem{d, slime-connection-list-make-default}
+@kbdanchor{d, slime-connection-list-make-default}
Make the connection at point the ``default'' connection. It will then
be used for commands in @code{slime-mode} source buffers.
-@kbditem{g, slime-update-connection-list}
+@kbdanchor{g, slime-update-connection-list}
Update the connection list in the buffer.
@kbditem{q, slime-temp-buffer-quit}
Quit the connection list (kill buffer, restore window configuration).
+@fcnanchor{slime-connect}
+Connect to a running Swank server.
+
+@fcnanchor{slime-disconnect}
+Disconnect all connextions.
+
+@fcnanchor{slime-connection-list-mode}
+Connection-list. @acronym{SLIME} Connection List Mode.
@end table
+@c -----------------------
@node Typeout frames, , Multiple connections, Extras
@section Typeout frames
@@ -1188,21 +1433,22 @@
expansions, and so on.
@table @kbd
-@item M-x slime-ensure-typeout-frame
+@fcnanchor{slime-ensure-typeout-frame}
Ensure that a typeout frame exists, creating one if necessary.
@end table
If the typeout frame is closed then the echo area will be used again
as usual.
-To have a typeout frame created automatically at startup you can use
-the @code{slime-connected-hook}:
+To have a typeout frame created automatically at startup you can add
+the @code{slime-connected-hook} to your @file{~/.emacs} file:
@example
(add-hook 'slime-connected-hook 'slime-ensure-typeout-frame)
@end example
-@node Customization, Credits, Extras, Top
+@c -----------------------
+@node Customization, Tips and Tricks, Extras, Top
@chapter Customization
@menu
@@ -1210,6 +1456,7 @@
* Lisp-side::
@end menu
+@c -----------------------
@node Emacs-side customization, Lisp-side, Customization, Customization
@section Emacs-side
@@ -1231,6 +1478,7 @@
(threads) in your Lisp system. It causes any necessary initialization
to be performed during Lisp server startup.
+@anchor{slime-complete-symbol-function}
@item slime-complete-symbol-function
The function to use for completion of Lisp symbols. Three completion
styles are available. The default @code{slime-complete-symbol*}
@@ -1258,16 +1506,15 @@
completes in the usual Emacs way. Finally, there is
@code{slime-fuzzy-complete-symbol}, which is quite different from both
of the above and tries to find best matches to an abbreviated symbol.
-It also has its own keybinding, defaulting to @kbd{C-c M-i}.
+It also has its own key binding, defaulting to @kbd{C-c M-i}.
@xref{slime-fuzzy-complete-symbol}, for more information.
-@item slime-translate-to-lisp-filename-function
-@itemx slime-translate-from-lisp-filename-function
-These functions can be used to translate filenames between Emacs and
-the Lisp system. They are useful if you run Emacs and Lisp on separate
-machines which share a common file system but use a different directory
-structure (different ``mount points''). This is most common with
-@acronym{SMB}-based file sharing.
+@item slime-filename-translations
+This variable controls filename translation between Emacs and the Lisp
+system. It is useful if you run Emacs and Lisp on separate machines
+which don't share a common file system or if they share the filessytem
+but have different layouts, as is the case with @acronym{SMB}-based
+file sharing.
@item slime-net-coding-system
If you want to transmit Unicode characters between Emacs and the Lisp
@@ -1288,6 +1535,7 @@
* Hooks::
@end menu
+@c -----------------------
@node Hooks, , Emacs-side customization, Emacs-side customization
@subsection Hooks
@@ -1301,8 +1549,7 @@
@item slime-connected-hook
This hook is run when @SLIME{} establishes a connection to a Lisp
-server. An example use is to create a Typeout frame (@xref{Typeout
-frames}.)
+server. An example use is to create a Typeout frame (@xref{Typeout frames}.)
@item sldb-hook
This hook is run after @SLDB{} is invoked. The hook functions are
@@ -1312,6 +1559,7 @@
@end table
+@c -----------------------
@node Lisp-side, , Emacs-side customization, Customization
@section Lisp-side (Swank)
@@ -1325,6 +1573,7 @@
* Other configurables::
@end menu
+@c -----------------------
@node Communication style, Other configurables, Lisp-side, Lisp-side
@subsection Communication style
@@ -1336,6 +1585,12 @@
The available communication styles are:
@table @code
+@item NIL
+This style simply loops reading input from the communication socket
+and serves @SLIME{} protocol events as they arise. The simplicity
+means that the Lisp cannot do any other processing while under
+@SLIME{}'s control.
+
@item :FD-HANDLER
This style uses the classical Unix-style ``@code{select()}-loop.''
Swank registers the communication socket with an event-dispatching
@@ -1367,12 +1622,13 @@
The default request handling style is chosen according to the
capabilities your Lisp system. The general order of preference is
-@code{:SPAWN}, then @code{:SIGIO}, then @code{:FD-HANDLER}. You can
-check the default style by calling
-@code{SWANK-BACKEND:PREFERRED-COMMUNICATION-STYLE}. You can also
-override the default by setting @code{SWANK:*COMMUNICATION-STYLE*} in
-your Swank init file.
+@code{:SPAWN}, then @code{:SIGIO}, then @code{:FD-HANDLER}, with
+@code{NIL} as a last resort. You can check the default style by
+calling @code{SWANK-BACKEND:PREFERRED-COMMUNICATION-STYLE}. You can
+also override the default by setting
+@code{SWANK:*COMMUNICATION-STYLE*} in your Swank init file.
+@c -----------------------
@node Other configurables, , Communication style, Lisp-side
@subsection Other configurables
@@ -1414,12 +1670,17 @@
@item SWANK:*USE-DEDICATED-OUTPUT-STREAM*
This variable controls an optimization for sending printed output from
-Lisp to Emacs. When @code{t} (the default) a separate socket is
-established solely for Lisp to send printed output to Emacs
-through. Without the optimization it is necessary to send output in
-protocol-messages to Emacs which must then be decoded, and this
-doesn't always keep up if Lisp starts ``spewing'' copious output.
+Lisp to Emacs. When @code{t} a separate socket is established solely for
+Lisp to send printed output to Emacs through. Without the optimization
+it is necessary to send output in protocol-messages to Emacs which must
+then be decoded, and this doesn't always keep up if Lisp starts
+``spewing'' copious output.
+@item SWANK:*DEDICATED-OUTPUT-STREAM-PORT*
+When @code{*USE-DEDICATED-OUTPUT-STREAM*} is @code{t} the stream will
+be opened on this port. The default value, @code{0}, means that the
+stream will be opened on some random port.
+
@item SWANK:*LOG-EVENTS*
Setting this variable to @code{t} causes all protocol messages
exchanged with Emacs to be printed to @code{*TERMINAL-IO*}. This is
@@ -1430,7 +1691,203 @@
@end table
-@node Credits, , Customization, Top
+@c -----------------------
+@node Tips and Tricks, Credits, Customization, Top
+@chapter Tips and Tricks
+
+@menu
+* Connecting to a remote lisp::
+* Global IO Redirection::
+* Auto-SLIME::
+@end menu
+
+@c -----------------------
+@node Connecting to a remote lisp
+@section Connecting to a remote lisp
+
+One of the advantages of the way @SLIME{} is implemented is that we
+can easily run the Emacs side (slime.el) on one machine and the lisp
+backend (swank) on another. The basic idea is to start up lisp on the
+remote machine, load swank and wait for incoming slime connections. On
+the local machine we start up emacs and tell slime to connect to the
+remote machine. The details are a bit messier but the underlying idea
+is that simple.
+
+@menu
+* Setting up the lisp image::
+* Setting up Emacs::
+* Setting up pathname translations::
+@end menu
+
+@c -----------------------
+@node Setting up the lisp image
+@subsection Setting up the lisp image
+
+
+When you want to load swank without going through the normal, Emacs
+based, process just load the @file{swank-loader.lisp} file. Just
+execute
+
+@example
+(load "/path/to/swank-loader.lisp")
+@end example
+
+inside a running lisp image@footnote{@SLIME{} also provides an
+@acronym{ASDF} system definiton which does the same thing}. Now all we
+need to do is startup our swank server. The first example assumes we're
+using the default settings.
+
+@example
+(swank:create-server)
+@end example
+
+Since we're going to be tunneling our connection via
+ssh@footnote{there is a way to connect without an ssh tunnel, but it
+has the side-effect of giving the entire world access to your lisp
+image, se we're not gonig to talk about it} and we'll only have on
+port open we want to tell swank to not use an extra connection for
+output:
+
+@example
+(setf swank:*use-dedicated-output-stream* nil)
+@end example
+
+@c -----------------------
+=======
+If you need to do anything particular
+(like be able to reconnect to swank after you're done), look into
+@code{swank:create-server}'s other arguments. Some of these arguments
+are
+@table @code
+
+@item :PORT
+Port number for the server to listen on (default: 4005).
+@item :STYLE
+See @xref{Communication style}.
+@item :DONT-CLOSE
+Boolean indicating if the server will continue to accept connections
+after the first one (default: @code{NIL}). For ``long-running'' lisp processes
+to which you want to be able to connect from time to time,
+specify @code{:dont-close t}
+@item :CODING-SYSTEM
+String designating the encoding to be used to communicate between the
+Emacs and Lisp.
+@end table
+
+So the more complete example will be
+@example
+(swank:create-server :port 4005 :dont-close t :coding-system "utf-8-unix")
+@end example
+On the emacs side you will use something like
+@example
+(setq slime-net-coding-system 'utf-8-unix)
+(slime-connect "127.0.0.1" 4005))
+@end example
+to connect to this lisp image from the same machine.
+
+
+>>>>>>> 1.49
+@node Setting up Emacs
+@subsection Setting up Emacs
+
+Now we need to create the tunnel between the local machine and the
+remote machine.
+
+@example
+ssh -L4005:127.0.0.1:4005 username@@remote.example.com
+@end example
+
+That ssh invocation creates an ssh tunnel between the port 4005 on our
+local machine and the port 4005 on the remote machine@footnote{By
+default swank listens for incoming connections on port 4005, had we
+passed a @code{:port} parameter to @code{swank:create-server} we'd be
+using that port number instead}.
+
+Finally we can start @SLIME{}:
+
+@example
+M-x slime-connect RET RET
+@end example
+
+The @kbd{RET RET} sequence just means that we want to use the default
+host (@code{127.0.0.1}) and the default port (@code{4005}). Even
+though we're connecting to a remote machine the ssh tunnel fools Emacs
+into thinking it's actually @code{127.0.0.1}.
+
+@c -----------------------
+@node Setting up pathname translations
+@subsection Setting up pathname translations
+
+One of the main problems with running swank remotely is that Emacs
+assumes the files can be found using normal filenames. if we want
+things like @code{slime-compile-and-load-file} (@kbd{C-c C-k}) and
+@code{slime-edit-definition} (@kbd{M-.}) to work correctly we need to
+find a way to let our local Emacs refer to remote files.
+
+There are, mainly, two ways to do this. The first is to mount, using
+NFS or similar, the remote machine's hard disk on the local machine's
+file system in such a fashion that a filename like
+(a)file{/opt/project/source.lisp} refers to the same file on both
+machines. Unfortunetly NFS is usually slow, often buggy, and not
+always feasable, fortunetely we have an ssh connection and Emacs'
+@code{tramp-mode} can do the rest.
+
+What we do is teach Emacs how to take a filename on the remote machine
+and translate it into something that tramp can understand and access
+(and vice-versa). Assuming the remote machine's host name is
+(a)code{remote.example.com}, @code{cl:machine-instance} returns
+``remote'' and we login as the user ``user'' we can use @SLIME{}'s
+built-in mechanism to setup the proper transaltions by simply doing:
+
+@example
+(push (slime-create-filename-translator :machine-instance "remote.example.com"
+ :remote-host "remote"
+ :username "user")
+ slime-filename-translations)
+@end example
+
+@c -----------------------
+@node Global IO Redirection
+@section Globally redirecting all IO to the REPL
+
+By default @SLIME{} does not change @code{*standard-output*} and
+friends outside of the @REPL{}. If you have any other threads which
+call @code{format}, @code{write-string}, etc. that output will be seen
+only in the @code{*inferior-lisp*} buffer or on the terminal, more
+often than not this inconvenient. So, if you want code such as this:
+
+@example
+(run-in-new-thread
+ (lambda ()
+ (write-line "In some random thread.~%" *standard-output*)))
+@end example
+
+to send its output to @SLIME{}'s repl buffer, as opposed to
+@code{*inferior-lisp*}, set @code{swank:*globally-redirect-io*} to T.
+
+Note that the value of this variable is only checked when swank
+accepts the connection so you should set it via
+(a)file{~/.swank.lisp}. Otherwise you will need to call
+@code{swank::globally-redirect-io-to-connection} yourself, but you
+shouldn't do that unless you know what you're doing.
+
+@c -----------------------
+@node Auto-SLIME
+@section Connecting to SLIME automatically
+
+To make @SLIME{} connect to your lisp whenever you open a lisp file
+just add this to your @file{.emacs}:
+
+@example
+(add-hook 'slime-mode-hook
+ (lambda ()
+ (unless (slime-connected-p)
+ (save-excursion (slime)))))
+@end example
+
+
+@c -----------------------
+@node Credits, Index to Key Bindings, Tips and Tricks, Top
@chapter Credits
@emph{The soppy ending...}
@@ -1466,4 +1923,768 @@
LispWorks. Thanks also to Alain Picard and Memetrics for funding
Martin's initial work on the LispWorks backend!
+
+@c -----------------------
+@node Index to Key Bindings, Index to Functions, Credits, Top
+@appendix Index to Key Bindings
+
+@table @kbd
+@kbdindex{SPC, slime-space}
+@kbdindex{C-c RET, slime-macroexpand-1}
+@kbdindex{C-c :, slime-interactive-eval}
+@kbdindex{C-c <, slime-list-callers}
+@kbdindex{C-c >, slime-list-callees}
+@kbdindex{C-c E, slime-edit-value}
+@kbdindex{C-c I, slime-inspect}
+@kbdindex{C-c u, slime-undefine-function}
+@kbdindex{C-c ~, slime-sync-package-and-default-directory}
+@kbdindex{C-c C-], slime-close-all-sexp}
+@kbdindex{C-c C-a, slime-nop}
+@kbdindex{C-c C-b, slime-interrupt}
+@kbdindex{C-c C-c, slime-compile-defun}
+@kbdindex{C-c C-d d, slime-describe-symbol}
+@kbdindex{C-c C-d ~, common-lisp-hyperspec-format}
+@kbdindex{C-c C-e, slime-interactive-eval}
+@kbdindex{C-c C-f, slime-describe-function}
+@kbdindex{C-c C-i, slime-complete-symbol}
+@kbdindex{C-c C-k, slime-compile-and-load-file}
+@kbdindex{C-c C-l, slime-load-file}
+@kbdindex{C-c C-m, slime-macroexpand-1}
+@kbdindex{C-c C-p, slime-pprint-eval-last-expression}
+@kbdindex{C-c C-q, slime-close-parens-at-point}
+@kbdindex{C-c C-r, slime-eval-region}
+@kbdindex{C-c C-s, slime-complete-form}
+@kbdindex{C-c C-t, slime-toggle-trace-fdefinition}
+@kbdindex{C-c C-v, slime-nop}
+@kbdindex{C-c C-w s, slime-who-sets}
+@kbdindex{C-c C-x c, slime-list-connections}
+@kbdindex{C-c C-x t, slime-list-threads}
+@kbdindex{C-c C-y, slime-call-defun}
+@kbdindex{C-c C-z, slime-switch-to-output-buffer}
+@kbdindex{C-c M-c, slime-remove-notes}.
+@kbdindex{C-c M-d, slime-disassemble-symbol}
+@kbdindex{C-c M-i, slime-fuzzy-complete-symbol}
+@kbdindex{C-c M-g, slime-quit}
+@kbdindex{C-c M-k, slime-compile-file}
+@kbdindex{C-c M-m, slime-macroexpand-all}
+@kbdindex{C-c M-p, slime-repl-set-package}
+@kbdindex{C-c M-q, slime-reindent-defun}
+@kbdindex{C-x 4 ., slime-edit-definition-other-window}
+@kbdindex{C-x 5 ., slime-edit-definition-other-frame}
+@kbdindex{C-x C-e, slime-eval-last-expression}
+@kbdindex{C-x M-e, slime-eval-last-expression-display-output}
+@kbdindex{M-TAB, slime-complete-symbol}
+@kbdindex{M-*, slime-pop-find-definition-stack}
+@kbdindex{M-., slime-edit-definition}
+@kbdindex{M-\,, slime-pop-find-definition-stack}
+@kbdindex{M-n, slime-next-note}
+@kbdindex{M-p, slime-previous-note}
+@kbdindex{C-M-i, slime-complete-symbol}
+@kbdindex{C-M-x, slime-eval-defun}
+@end table
+
+@c -----------------------
+@node Index to Functions, , Index to Key Bindings, Top
+@appendix Index to Functions
+
+@c Note: the functions commented out below are in slime.el but as
+@c yet unreferenced (and may or may not be -jkc-).
+
+@table @code
+@fcnindex{common-lisp-hyperspec-format}
+@c @fcnindex{sldb-mode-hook}
+@c @fcnindex{slime-mode-hook}
+@c @fcnindex{slime-repl-mode-hook}
+@c @fcnindex{compile}
+@c @fcnindex{compile-defun}
+@c @fcnindex{fboundp}
+@c @fcnindex{def-sldb-face}
+@c @fcnindex{def-sldb-faces}
+@c @fcnindex{def-slime-selector-method}
+@c @fcnindex{def-slime-test}
+@c @fcnindex{define-sldb-invoke-restart-key}
+@c @fcnindex{define-sldb-invoke-restart-keys}
+@c @fcnindex{define-slime-dialect}
+@c @fcnindex{defslime-repl-shortcut}
+@c @fcnindex{destructure-case}
+@c @fcnindex{in-sldb-face}
+@c @fcnindex{inferior-slime-closing-return}
+@c @fcnindex{inferior-slime-indent-line}
+@c @fcnindex{inferior-slime-input-complete-p}
+@c @fcnindex{inferior-slime-return}
+@fcnindex{sldb-abort}
+@c @fcnindex{sldb-activate}
+@c @fcnindex{sldb-add-face}
+@c @fcnindex{sldb-backward-frame}
+@c @fcnindex{sldb-beginning-of-backtrace}
+@c @fcnindex{sldb-break}
+@c @fcnindex{sldb-break-on-return}
+@fcnindex{sldb-break-with-default-debugger}
+@c @fcnindex{sldb-buffers}
+@c @fcnindex{sldb-catch-tags}
+@fcnindex{sldb-continue}
+@c @fcnindex{sldb-debugged-continuations}
+@c @fcnindex{sldb-default-action}
+@c @fcnindex{sldb-default-action/mouse}
+@c @fcnindex{sldb-delete-overlays}
+@c @fcnindex{sldb-details-down}
+@c @fcnindex{sldb-details-up}
+@fcnindex{sldb-disassemble}
+@c @fcnindex{sldb-dispatch-extras}
+@c @fcnindex{sldb-down}
+@c @fcnindex{sldb-end-of-backtrace}
+@fcnindex{sldb-eval-in-frame}
+@c @fcnindex{sldb-exit}
+@c @fcnindex{sldb-fetch-all-frames}
+@c @fcnindex{sldb-fetch-more-frames}
+@c @fcnindex{sldb-find-buffer}
+@c @fcnindex{sldb-format-reference-node}
+@c @fcnindex{sldb-format-reference-source}
+@c @fcnindex{sldb-forward-frame}
+@c @fcnindex{sldb-frame-details-visible-p}
+@c @fcnindex{sldb-frame-locals}
+@c @fcnindex{sldb-frame-number-at-point}
+@c @fcnindex{sldb-frame-region}
+@c @fcnindex{sldb-get-buffer}
+@c @fcnindex{sldb-get-default-buffer}
+@c @fcnindex{sldb-goto-last-frame}
+@c @fcnindex{sldb-help-summary}
+@c @fcnindex{sldb-hide-frame-details}
+@c @fcnindex{sldb-highlight-sexp}
+@c @fcnindex{sldb-insert-condition}
+@c @fcnindex{sldb-insert-frame}
+@c @fcnindex{sldb-insert-frames}
+@c @fcnindex{sldb-insert-locals}
+@c @fcnindex{sldb-insert-references}
+@c @fcnindex{sldb-insert-restarts}
+@c @fcnindex{sldb-inspect-condition}
+@fcnindex{sldb-inspect-in-frame}
+@c @fcnindex{sldb-inspect-var}
+@c @fcnindex{sldb-invoke-restart}
+@c @fcnindex{sldb-level}
+@c @fcnindex{sldb-list-catch-tags}
+@c @fcnindex{sldb-list-locals}
+@c @fcnindex{sldb-lookup-reference}
+@c @fcnindex{sldb-maybe-recenter-region}
+@c @fcnindex{sldb-next}
+@c @fcnindex{sldb-out}
+@fcnindex{sldb-pprint-eval-in-frame}
+@c @fcnindex{sldb-previous-frame-number}
+@c @fcnindex{sldb-print-condition}
+@c @fcnindex{sldb-prune-initial-frames}
+@fcnindex{sldb-quit}
+@c @fcnindex{sldb-reference-properties}
+@c @fcnindex{sldb-restart-at-point}
+@fcnindex{sldb-restart-frame}
+@fcnindex{sldb-return-from-frame}
+@c @fcnindex{sldb-setup}
+@c @fcnindex{sldb-show-frame-details}
+@c @fcnindex{sldb-show-frame-source}
+@fcnindex{sldb-show-source}
+@fcnindex{sldb-step}
+@c @fcnindex{sldb-sugar-move}
+@fcnindex{sldb-toggle-details}
+@c @fcnindex{sldb-up}
+@c @fcnindex{sldb-var-number-at-point}
+@c @fcnindex{sldb-xemacs-emulate-point-entered-hook}
+@c @fcnindex{sldb-xemacs-post-command-hook}
+@fcnindex{slime-abort-connection}
+@c @fcnindex{slime-accept-process-output}
+@c @fcnindex{slime-activate-font-lock-magic}
+@c @fcnindex{slime-add-face}
+@c @fcnindex{slime-add-presentation-properties}
+@c @fcnindex{slime-after-change-function}
+@c @fcnindex{slime-alistify}
+@fcnindex{slime-apropos}
+@fcnindex{slime-apropos-all}
+@fcnindex{slime-apropos-package}
+@c @fcnindex{slime-apropos-summary} [internal]
+@c @fcnindex{slime-arglist}
+@c @fcnindex{slime-arglist-specializers}
+@c @fcnindex{slime-at-top-level-p}
+@c @fcnindex{slime-autodoc} [internal]
+@c @fcnindex{slime-autodoc-global-at-point} [internal]
+@c @fcnindex{slime-autodoc-message} [internal]
+@c @fcnindex{slime-autodoc-message-dimensions} [internal]
+@c @fcnindex{slime-autodoc-message-ok-p} [internal]
+@fcnindex{slime-autodoc-mode}
+@c @fcnindex{slime-autodoc-pre-command-refresh-echo-area} [internal]
+@c @fcnindex{slime-autodoc-start-timer} ??
+@c @fcnindex{slime-autodoc-stop-timer} [internal]
+@c @fcnindex{slime-autodoc-thing-at-point} [internal]
+@c @fcnindex{slime-autodoc-timer-hook} [internal]
+@c @fcnindex{slime-background-activities-enabled-p}
+@c @fcnindex{slime-background-message}
+@c @fcnindex{slime-batch-test}
+@c @fcnindex{slime-beginning-of-comment} [internal]
+@c @fcnindex{slime-beginning-of-list} [internal]
+@c @fcnindex{slime-beginning-of-symbol} [internal]
+@c @fcnindex{slime-bogus-completion-alist}
+@c @fcnindex{slime-browse-classes}
+@c @fcnindex{slime-browse-xrefs}
+@c @fcnindex{slime-buffer-substring-with-reified-output}
+@c @fcnindex{slime-busy-p}
+@c @fcnindex{slime-bytecode-stale-p}
+@fcnindex{slime-call-defun}
+@c @fcnindex{slime-call-describer}
+@c @fcnindex{slime-call-with-browser-setup}
+@fcnindex{slime-calls-who}
+@c @fcnindex{slime-changelog-date}
+@c @fcnindex{slime-cheat-sheet}
+@c @fcnindex{slime-cheat-sheet-table}
+@c @fcnindex{slime-check}
+@c @fcnindex{slime-check-coding-system}
+@c @fcnindex{slime-check-connected}
+@c @fcnindex{slime-check-eval-in-emacs-enabled}
+@c @fcnindex{slime-check-sldb-level}
+@c @fcnindex{slime-check-top-level}
+@c @fcnindex{slime-choose-connection}
+@c @fcnindex{slime-choose-overlay-for-sexp}
+@c @fcnindex{slime-choose-overlay-region}
+@c @fcnindex{slime-cl-symbol-external-ref-p}
+@c @fcnindex{slime-cl-symbol-name}
+@c @fcnindex{slime-cl-symbol-package}
+@fcnindex{slime-close-all-sexp}
+@fcnindex{slime-close-parens-at-point}
+@c @fcnindex{slime-coding-system-cl-name}
+@c @fcnindex{slime-coding-system-mulibyte-p}
+@c @fcnindex{slime-compilation-finished}
+@c @fcnindex{slime-compilation-finished-continuation}
+@fcnindex{slime-compile-and-load-file}
+@fcnindex{slime-compile-defun}
+@fcnindex{slime-compile-file}
+@fcnindex{slime-compile-region}
+@c @fcnindex{slime-compile-string} [internal]
+@fcnindex{slime-compiler-macroexpand}
+@fcnindex{slime-compiler-macroexpand-1}
+@c @fcnindex{slime-compiler-notes} [internal]
+@fcnindex{slime-compiler-notes-default-action-or-show-details}
+@fcnindex{slime-compiler-notes-default-action-or-show-details/mouse}
+@fcnindex{slime-compiler-notes-quit}
+@fcnindex{slime-compiler-notes-show-details}
+@c @fcnindex{slime-compiler-notes-to-tree} [internal]
+@c @fcnindex{slime-complete-delay-restoration} [internal]
+@c @fcnindex{slime-complete-forget-window-configuration} [internal]
+@fcnindex{slime-complete-form}
+@c @fcnindex{slime-complete-maybe-restore-window-configuration} [internal]
+@c @fcnindex{slime-complete-maybe-save-window-configuration} [internal]
+@c @fcnindex{slime-complete-restore-window-configuration} [internal]
+@fcnindex{slime-complete-symbol}
+@c @fcnindex{slime-complete-symbol*} [internal]
+@c @fcnindex{slime-complete-symbol*-fancy-bit} [internal]
+@c @fcnindex{slime-completion-window-active-p} [internal]
+@c @fcnindex{slime-completions} [internal]
+@c @fcnindex{slime-completions-for-keyword} [internal]
+@fcnindex{slime-connect}
+@c @fcnindex{slime-connected-p} [internal]
+@c @fcnindex{slime-connection} [internal]
+@c @fcnindex{slime-connection-at-point} [internal]
+@c @fcnindex{slime-connection-close-hook} [internal]
+@fcnindex{slime-connection-list-make-default}
+@fcnindex{slime-connection-list-mode}
+@c @fcnindex{slime-connection-port} [internal]
+@c @fcnindex{slime-control-modified-char}
+@c @fcnindex{slime-copy-or-inspect-presentation-at-mouse}
+@c @fcnindex{slime-copy-presentation-at-mouse}
+@c @fcnindex{slime-create-message-window}
+@c @fcnindex{slime-create-note-overlay}
+@c @fcnindex{slime-create-test-results-buffer}
+@c @fcnindex{slime-current-connection} [internal]
+@c @fcnindex{slime-current-package} [internal]
+@c @fcnindex{slime-def-connection-var}
+@c @fcnindex{slime-define-keys}
+@c @fcnindex{slime-defun-at-point}
+@c @fcnindex{slime-delete-hidden-outline-text}
+@fcnindex{slime-describe-function}
+@c @fcnindex{slime-describe-presentation-at-mouse}
+@fcnindex{slime-describe-symbol}
+@fcnindex{slime-disassemble-symbol}
+@fcnindex{slime-disconnect}
+@c @fcnindex{slime-dismiss-temp-buffer}
+@c @fcnindex{slime-dispatch-event}
+@c @fcnindex{slime-display-buffer-region}
+@c @fcnindex{slime-display-completion-list}
+@c @fcnindex{slime-display-eval-result}
+@c @fcnindex{slime-display-message}
+@c @fcnindex{slime-display-output-buffer}
+@c @fcnindex{slime-display-xref-buffer}
+@c @fcnindex{slime-documentation}
+@c @fcnindex{slime-draw-connection-list}
+@c @fcnindex{slime-easy-menu}
+@c @fcnindex{slime-echo-arglist}
+@c @fcnindex{slime-ed}
+@fcnindex{slime-edit-definition}
+@fcnindex{slime-edit-definition-other-frame}
+@fcnindex{slime-edit-definition-other-window}
+@fcnindex{slime-edit-definition-with-etags}
+@fcnindex{slime-edit-value}
+@c @fcnindex{slime-edit-value-callback}
+@c @fcnindex{slime-edit-value-commit}
+@c @fcnindex{slime-emacs-20-p}
+@c @fcnindex{slime-enclosing-operator-names}
+@c @fcnindex{slime-end-of-symbol}
+@c @fcnindex{slime-ensure-presentation-overlay}
+@c @fcnindex{slime-ensure-typeout-frame}
+@c @fcnindex{slime-etags-definitions}
+@c @fcnindex{slime-eval}
+@c @fcnindex{slime-eval-async}
+@c @fcnindex{slime-eval-buffer}
+@fcnindex{slime-eval-defun}
+@c @fcnindex{slime-eval-describe}
+@c @fcnindex{slime-eval-feature-conditional}
+@c @fcnindex{slime-eval-for-lisp}
+@fcnindex{slime-eval-last-expression}
+@fcnindex{slime-eval-last-expression-display-output}
+@c @fcnindex{slime-eval-macroexpand}
+@c @fcnindex{slime-eval-macroexpand-inplace}
+@c @fcnindex{slime-eval-print}
+@c @fcnindex{slime-eval-print-last-expression}
+@fcnindex{slime-eval-region}
+@c @fcnindex{slime-eval-with-transcript}
+@c @fcnindex{slime-events-buffer}
+@c @fcnindex{slime-execute-tests}
+@c @fcnindex{slime-expand-abbreviations-and-complete}
+@c @fcnindex{slime-expand-class-node}
+@c @fcnindex{slime-expand-xrefs}
+@c @fcnindex{slime-extract-context}
+@c @fcnindex{slime-face-inheritance-possible-p}
+@c @fcnindex{slime-fetch-browsable-xrefs}
+@c @fcnindex{slime-filter-buffers}
+@c @fcnindex{slime-find-asd} [internal]
+@c @fcnindex{slime-find-buffer-package} [internal]
+@c @fcnindex{slime-find-coding-system} [internal]
+@c @fcnindex{slime-find-connection-by-name} [internal]
+@c @fcnindex{slime-find-filename-translators} [internal]
+@c @fcnindex{slime-find-next-note} [internal]
+@c @fcnindex{slime-find-note} [internal]
+@c @fcnindex{slime-find-previous-note} [internal]
+@c @fcnindex{slime-first-change-hook}
+@c @fcnindex{slime-fontify-string}
+@c @fcnindex{slime-forward-blanks}
+@c @fcnindex{slime-forward-positioned-source-path}
+@c @fcnindex{slime-forward-reader-comment}
+@c @fcnindex{slime-forward-reader-conditional}
+@c @fcnindex{slime-forward-sexp}
+@c @fcnindex{slime-forward-source-path}
+@c @fcnindex{slime-frame-windows}
+@c @fcnindex{slime-from-lisp-filename}
+@fcnindex{slime-fuzzy-abort}
+@fcnindex{slime-fuzzy-complete-symbol}
+@fcnindex{slime-fuzzy-completions-mode}
+@c @fcnindex{slime-fuzzy-choices-buffer} [internal]
+@c @fcnindex{slime-fuzzy-completions} [internal]
+@c @fcnindex{slime-fuzzy-done} [internal]
+@c @fcnindex{slime-fuzzy-insert} [internal]
+@c @fcnindex{slime-fuzzy-insert-completion-choice} [internal]
+@c @fcnindex{slime-fuzzy-insert-from-point} [internal]
+@c @fcnindex{slime-fuzzy-maybe-restore-window-configuration} [internal]
+@c @fcnindex{slime-fuzzy-next} ???
+@c @fcnindex{slime-fuzzy-post-command-hook} [internal]
+@c @fcnindex{slime-fuzzy-prev} ???
+@c @fcnindex{slime-fuzzy-save-window-configuration} [internal]
+@c @fcnindex{slime-fuzzy-select} ???
+@c @fcnindex{slime-fuzzy-select/mouse} ???
+@c @fcnindex{slime-fuzzy-selected} [internal]
+@c @fcnindex{slime-fuzzy-window-configuration-change} [internal]
+@c @fcnindex{slime-fuzzy-window-configuration-change-add-hook} [internal]
+@c @fcnindex{slime-generate-connection-name}
+@c @fcnindex{slime-get-arglist} [internal]
+@c @fcnindex{slime-get-cached-autodoc} [internal]
+@c @fcnindex{slime-get-fuzzy-buffer} [internal]
+@c @fcnindex{slime-global-variable-name-p} [internal]
+@fcnindex{slime-goto-connection}
+@c @fcnindex{slime-goto-definition} ???
+@c @fcnindex{slime-goto-definition-other-window} [internal]
+@c @fcnindex{slime-goto-location-buffer} [internal]
+@c @fcnindex{slime-goto-location-position} [internal]
+@c @fcnindex{slime-goto-next-xref} [internal]
+@c @fcnindex{slime-goto-source-location} [internal]
+@fcnindex{slime-goto-xref}
+@c @fcnindex{slime-group-similar}
+@c @fcnindex{slime-handle-indentation-update}
+@c @fcnindex{slime-handle-repl-shortcut}
+@c @fcnindex{slime-hide-inferior-lisp-buffer} [internal]
+@c @fcnindex{slime-highlight-edits}
+@c @fcnindex{slime-highlight-edits-compile-hook}
+@c @fcnindex{slime-highlight-edits-init-buffer}
+@c @fcnindex{slime-highlight-edits-reset-buffer}
+@c @fcnindex{slime-highlight-notes}
+@fcnindex{slime-hyperspec-lookup}
+@c @fcnindex{slime-in-expression-p}
+@c @fcnindex{slime-indent-and-complete-symbol}
+@c @fcnindex{slime-inferior-connect} [internal]
+@c @fcnindex{slime-inferior-lisp-args} [internal]
+@c @fcnindex{slime-init-command}
+@c @fcnindex{slime-init-connection-state}
+@c @fcnindex{slime-init-keymaps}
+@c @fcnindex{slime-init-output-buffer}
+@c @fcnindex{slime-init-xref-buffer}
+@c @fcnindex{slime-input-complete-p}
+@c @fcnindex{slime-insert-arglist}
+@c @fcnindex{slime-insert-balanced-comments}
+@c @fcnindex{slime-insert-presentation}
+@c @fcnindex{slime-insert-transcript-delimiter}
+@c @fcnindex{slime-insert-xrefs}
+@c @fcnindex{slime-inside-comment-p}
+@fcnindex{slime-inspect}
+@c @fcnindex{slime-inspect-presentation-at-mouse}
+@c @fcnindex{slime-inspector-buffer}
+@fcnindex{slime-inspector-copy-down}
+@fcnindex{slime-inspector-describe}
+@c @fcnindex{slime-inspector-fontify}
+@c @fcnindex{slime-inspector-insert-ispec}
+@fcnindex{slime-inspector-next}
+@c @fcnindex{slime-inspector-next-inspectable-object}
+@c @fcnindex{slime-inspector-operate-on-click}
+@fcnindex{slime-inspector-operate-on-point}
+@fcnindex{slime-inspector-pop}
+@c @fcnindex{slime-inspector-pprint}
+@c @fcnindex{slime-inspector-previous-inspectable-object}
+@fcnindex{slime-inspector-quit}
+@c @fcnindex{slime-inspector-reinspect}
+@fcnindex{slime-interactive-eval}
+@fcnindex{slime-interrupt}
+@c @fcnindex{slime-intersperse}
+@c @fcnindex{slime-io-speed-test}
+@c @fcnindex{slime-isearch}
+@c @fcnindex{slime-isearch-with-function}
+@c @fcnindex{slime-keys}
+@c @fcnindex{slime-kill-all-buffers}
+@c @fcnindex{slime-last-expression}
+@c @fcnindex{slime-length>}
+@c @fcnindex{slime-lisp-mode-hook}
+@c @fcnindex{slime-list-all-repl-shortcuts}
+@fcnindex{slime-list-callees}
+@fcnindex{slime-list-callers}
+@c @fcnindex{slime-list-compiler-notes}
+@fcnindex{slime-list-connections}
+@c @fcnindex{slime-list-repl-short-cuts}
+@fcnindex{slime-list-threads}
+@fcnindex{slime-load-file}
+@c @fcnindex{slime-load-file-set-package}
+@c @fcnindex{slime-load-system}
+@c @fcnindex{slime-log-event}
+@c @fcnindex{slime-lookup-lisp-implementation}
+@c @fcnindex{slime-lookup-shortcut}
+@fcnindex{slime-macroexpand-1}
+@fcnindex{slime-macroexpand-1-inplace}
+@c @fcnindex{slime-macroexpand-again}
+@fcnindex{slime-macroexpand-all}
+@c @fcnindex{slime-macroexpand-all-inplace}
+@c @fcnindex{slime-make-default-connection}
+@c @fcnindex{slime-make-net-buffer}
+@c @fcnindex{slime-make-tramp-file-name}
+@c @fcnindex{slime-make-typeout-frame}
+@c @fcnindex{slime-make-variables-buffer-local}
+@c @fcnindex{slime-mark-input-start}
+@c @fcnindex{slime-mark-output-end}
+@c @fcnindex{slime-mark-output-start}
+@c @fcnindex{slime-mark-presentation-end}
+@c @fcnindex{slime-mark-presentation-end-handler}
+@c @fcnindex{slime-mark-presentation-start}
+@c @fcnindex{slime-mark-presentation-start-handler}
+@c @fcnindex{slime-maybe-complete-as-filename}
+@c @fcnindex{slime-maybe-display-output-buffer}
+@c @fcnindex{slime-maybe-list-compiler-notes}
+@c @fcnindex{slime-maybe-show-xrefs-for-notes}
+@c @fcnindex{slime-maybe-start-lisp}
+@c @fcnindex{slime-menu-choices-for-presentation}
+@c @fcnindex{slime-merge-note-into-overlay}
+@c @fcnindex{slime-merge-notes}
+@c @fcnindex{slime-merge-notes-for-display}
+@c @fcnindex{slime-message}
+@c @fcnindex{slime-minibuffer-respecting-message}
+@c @fcnindex{slime-most-severe}
+@c @fcnindex{slime-net-close}
+@c @fcnindex{slime-net-connect}
+@c @fcnindex{slime-net-decode-length}
+@c @fcnindex{slime-net-encode-length}
+@c @fcnindex{slime-net-filter}
+@c @fcnindex{slime-net-have-input-p}
+@c @fcnindex{slime-net-read}
+@c @fcnindex{slime-net-send}
+@c @fcnindex{slime-net-sentinel}
+@c @fcnindex{slime-next-line/not-add-newlines}
+@c @fcnindex{slime-next-location}
+@fcnindex{slime-next-note}
+@fcnindex{slime-nop}
+@c @fcnindex{slime-note-at-point}
+@c @fcnindex{slime-note-count-string}
+@c @fcnindex{slime-note-has-location-p}
+@c @fcnindex{slime-note-overlay-p}
+@c @fcnindex{slime-note-overlays-at-point}
+@c @fcnindex{slime-note.location}
+@c @fcnindex{slime-note.message}
+@c @fcnindex{slime-note.references}
+@c @fcnindex{slime-note.severity}
+@c @fcnindex{slime-note.short-message}
+@c @fcnindex{slime-notes-in-same-location-p}
+@c @fcnindex{slime-one-line-ify}
+@c @fcnindex{slime-oneliner}
+@c @fcnindex{slime-only-whitespace-p}
+@c @fcnindex{slime-oos}
+@c @fcnindex{slime-open-inspector}
+@c @fcnindex{slime-open-stream-to-lisp}
+@c @fcnindex{slime-output-buffer}
+@c @fcnindex{slime-output-filter}
+@c @fcnindex{slime-overlay-note}
+@c @fcnindex{slime-parse-context}
+@c @fcnindex{slime-parse-context}
+@c @fcnindex{slime-parse-extended-operator-name}
+@c @fcnindex{slime-parse-extended-operator-name/apply}
+@c @fcnindex{slime-parse-extended-operator-name/cerror}
+@c @fcnindex{slime-parse-extended-operator-name/defmethod}
+@c @fcnindex{slime-parse-extended-operator-name/make-instance}
+@c @fcnindex{slime-parse-toplevel-form}
+@c @fcnindex{slime-pattern-path}
+@c @fcnindex{slime-ping}
+@c @fcnindex{slime-point-moves-p}
+@fcnindex{slime-pop-find-definition-stack}
+@c @fcnindex{slime-pop-to-other-window}
+@c @fcnindex{slime-post-command-hook}
+@fcnindex{slime-pprint-eval-last-expression}
+@c @fcnindex{slime-pprint-event}
+@c @fcnindex{slime-pre-command-hook}
+@c @fcnindex{slime-presentation-around-click}
+@c @fcnindex{slime-presentation-around-or-before-point}
+@c @fcnindex{slime-presentation-around-point}
+@c @fcnindex{slime-presentation-expression}
+@c @fcnindex{slime-presentation-menu}
+@c @fcnindex{slime-presentation-start-p}
+@c @fcnindex{slime-presentation-stop-p}
+@c @fcnindex{slime-presentation-whole-p}
+@c @fcnindex{slime-presentations-around-point}
+@c @fcnindex{slime-preserve-zmacs-region}
+@c @fcnindex{slime-pretty-lambdas}
+@c @fcnindex{slime-pretty-package-name}
+@c @fcnindex{slime-pretty-print-presentation-at-mouse}
+@fcnindex{slime-previous-note}
+@c @fcnindex{slime-prin1-to-string}
+@c @fcnindex{slime-print-apropos}
+@c @fcnindex{slime-print-check-error}
+@c @fcnindex{slime-print-check-failed}
+@c @fcnindex{slime-print-check-ok}
+@c @fcnindex{slime-process}
+@c @fcnindex{slime-process-available-input}
+@fcnindex{slime-profile-package}
+@fcnindex{slime-profile-report}
+@fcnindex{slime-profile-reset}
+@fcnindex{slime-profiled-functions}
+@c @fcnindex{slime-propertize-region}
+@c @fcnindex{slime-property-bounds}
+@c @fcnindex{slime-property-position}
+@c @fcnindex{slime-push-definition-stack}
+@c @fcnindex{slime-qualify-cl-symbol}
+@c @fcnindex{slime-qualify-cl-symbol-name}
+@fcnindex{slime-quit}
+@c @fcnindex{slime-quit-connection-at-point}
+@c @fcnindex{slime-quit-lisp}
+@c @fcnindex{slime-quit-sentinel}
+@c @fcnindex{slime-random-words-of-encouragement}
+@c @fcnindex{slime-re-evaluate-defvar}
+@c @fcnindex{slime-read-from-minibuffer}
+@c @fcnindex{slime-read-interactive-args}
+@c @fcnindex{slime-read-object}
+@c @fcnindex{slime-read-package-name}
+@c @fcnindex{slime-read-port-and-connect}
+@c @fcnindex{slime-read-swank-port}
+@c @fcnindex{slime-read-symbol-name}
+@c @fcnindex{slime-read-system-name}
+@c @fcnindex{slime-read-test-name}
+@c @fcnindex{slime-reading-p}
+@c @fcnindex{slime-recenter-window}
+@c @fcnindex{slime-recently-visited-buffer}
+@c @fcnindex{slime-recompile-bytecode}
+@c @fcnindex{slime-region-for-defun-at-point}
+@c @fcnindex{slime-reify-old-output}
+@fcnindex{slime-reindent-defun}
+@c @fcnindex{slime-reinitialize-inferior-lisp-p} [internal]
+@c @fcnindex{slime-remove-balanced-comments}
+@c @fcnindex{slime-remove-edits}
+@fcnindex{slime-remove-notes}
+@c @fcnindex{slime-remove-old-overlays}
+@c @fcnindex{slime-remove-presentation-properties}
+@c @fcnindex{slime-repl}
+@c @fcnindex{slime-repl-abort-read}
+@c @fcnindex{slime-repl-add-to-input-history}
+@c @fcnindex{slime-repl-at-prompt-end-p}
+@fcnindex{slime-repl-beginning-of-defun}
+@fcnindex{slime-repl-bol}
+@c @fcnindex{slime-repl-buffer}
+@c @fcnindex{slime-repl-call-with-handler}
+@fcnindex{slime-repl-clear-buffer}
+@fcnindex{slime-repl-clear-output}
+@fcnindex{slime-repl-closing-return}
+@c @fcnindex{slime-repl-current-input}
+@c @fcnindex{slime-repl-delete-current-input}
+@fcnindex{slime-repl-end-of-defun}
+@c @fcnindex{slime-repl-eol}
+@c @fcnindex{slime-repl-eval-string}
+@c @fcnindex{slime-repl-find-prompt}
+@c @fcnindex{slime-repl-grab-old-input}
+@c @fcnindex{slime-repl-grab-old-output}
+@c @fcnindex{slime-repl-history-replace}
+@c @fcnindex{slime-repl-in-input-area-p}
+@c @fcnindex{slime-repl-input-line-beginning-position}
+@c @fcnindex{slime-repl-insert-prompt}
+@c @fcnindex{slime-repl-insert-result}
+@c @fcnindex{slime-repl-kill-input}
+@c @fcnindex{slime-repl-load-history}
+@c @fcnindex{slime-repl-matching-input-regexp}
+@c @fcnindex{slime-repl-merge-histories}
+@c @fcnindex{slime-repl-mode}
+@c @fcnindex{slime-repl-move-output-mark-before-prompt}
+@fcnindex{slime-repl-newline-and-indent}
+@fcnindex{slime-repl-next-input}
+@fcnindex{slime-repl-next-matching-input}
+@fcnindex{slime-repl-next-prompt}
+@c @fcnindex{slime-repl-position-in-history}
+@fcnindex{slime-repl-previous-input}
+@fcnindex{slime-repl-previous-matching-input}
+@fcnindex{slime-repl-previous-prompt}
+@c @fcnindex{slime-repl-read-break}
+@c @fcnindex{slime-repl-read-history}
+@c @fcnindex{slime-repl-read-history-filename}
+@c @fcnindex{slime-repl-read-string}
+@c @fcnindex{slime-repl-recenter-if-needed}
+@c @fcnindex{slime-repl-replace-input}
+@fcnindex{slime-repl-return}
+@c @fcnindex{slime-repl-return-string}
+@c @fcnindex{slime-repl-safe-load-history}
+@c @fcnindex{slime-repl-safe-save-merged-history}
+@c @fcnindex{slime-repl-save-all-histories}
+@c @fcnindex{slime-repl-save-history}
+@c @fcnindex{slime-repl-save-merged-history}
+@c @fcnindex{slime-repl-send-input}
+@c @fcnindex{slime-repl-send-string}
+@fcnindex{slime-repl-set-package}
+@c @fcnindex{slime-repl-show-abort}
+@c @fcnindex{slime-repl-show-maximum-output}
+@c @fcnindex{slime-repl-update-banner}
+@c @fcnindex{slime-reset}
+@c @fcnindex{slime-reset-repl-markers}
+@fcnindex{slime-restart-connection-at-point}
+@fcnindex{slime-restart-inferior-lisp}
+@c @fcnindex{slime-restart-sentinel} [internal]
+@c @fcnindex{slime-run-one-test}
+@c @fcnindex{slime-run-tests}
+@c @fcnindex{slime-run-when-idle}
+@c @fcnindex{slime-safe-encoding-p}
+@c @fcnindex{slime-same-line-p}
+@c @fcnindex{slime-save-some-lisp-buffers}
+@c @fcnindex{slime-scheme-mode-hook}
+@fcnindex{slime-scratch}
+@c @fcnindex{slime-scratch-buffer}
+@c @fcnindex{slime-search-call-site}
+@c @fcnindex{slime-search-method-location}
+@c @fcnindex{slime-search-property-change-fn}
+@c @fcnindex{slime-search-suppressed-forms}
+@c @fcnindex{slime-secret}
+@c @fcnindex{slime-select-connection}
+@fcnindex{slime-selector}
+@c @fcnindex{slime-send}
+@c @fcnindex{slime-send-sigint}
+@c @fcnindex{slime-set-connection-info}
+@c @fcnindex{slime-set-default-directory}
+@c @fcnindex{slime-set-inferior-process}
+@c @fcnindex{slime-set-package}
+@c @fcnindex{slime-set-state}
+@c @fcnindex{slime-set-truncate-lines}
+@c @fcnindex{slime-setup-command-hooks}
+@c @fcnindex{slime-setup-connection}
+@c @fcnindex{slime-setup-first-change-hook}
+@c @fcnindex{slime-severity-face}
+@c @fcnindex{slime-severity-label}
+@c @fcnindex{slime-sexp-at-point}
+@c @fcnindex{slime-sexp-at-point-or-error}
+@c @fcnindex{slime-shared-lisp-mode-hook}
+@c @fcnindex{slime-show-apropos}
+@c @fcnindex{slime-show-buffer-position}
+@c @fcnindex{slime-show-definitions}
+@c @fcnindex{slime-show-description}
+@c @fcnindex{slime-show-last-output}
+@c @fcnindex{slime-show-last-output-region}
+@c @fcnindex{slime-show-note}
+@c @fcnindex{slime-show-note-counts}
+@c @fcnindex{slime-show-source-location}
+@c @fcnindex{slime-show-xref}
+@c @fcnindex{slime-show-xrefs}
+@c @fcnindex{slime-simple-complete-symbol}
+@c @fcnindex{slime-simple-completions}
+@c @fcnindex{slime-sldb-level=}
+@fcnindex{slime-space}
+@c @fcnindex{slime-start-and-load}
+@c @fcnindex{slime-start-lisp}
+@c @fcnindex{slime-start-swank-server}
+@c @fcnindex{slime-swank-port-file}
+@fcnindex{slime-switch-to-output-buffer}
+@c @fcnindex{slime-switch-to-scratch-buffer}
+@c @fcnindex{slime-symbol-at-point}
+@c @fcnindex{slime-symbol-end-pos}
+@c @fcnindex{slime-symbol-name-at-point}
+@c @fcnindex{slime-symbol-start-pos}
+@c @fcnindex{slime-sync}
+@fcnindex{slime-sync-package-and-default-directory}
+@c @fcnindex{slime-sync-to-top-level}
+@fcnindex{slime-temp-buffer-quit}
+@c @fcnindex{slime-temporarily-highlight-note}
+@c @fcnindex{slime-test-expect}
+@c @fcnindex{slime-test-failure}
+@c @fcnindex{slime-test-heading}
+@c @fcnindex{slime-test-message}
+@c @fcnindex{slime-test-should-fail-p}
+@c @fcnindex{slime-thread-attach}
+@c @fcnindex{slime-thread-debug}
+@c @fcnindex{slime-thread-insert}
+@c @fcnindex{slime-thread-kill}
+@c @fcnindex{slime-thread-quit}
+@c @fcnindex{slime-to-feature-keyword}
+@c @fcnindex{slime-to-lisp-filename}
+@fcnindex{slime-toggle-profile-fdefinition}
+@fcnindex{slime-toggle-trace-fdefinition}
+@c @fcnindex{slime-trace-query}
+@c @fcnindex{slime-tree-at-point}
+@c @fcnindex{slime-tree-decoration}
+@c @fcnindex{slime-tree-default-printer}
+@c @fcnindex{slime-tree-delete}
+@c @fcnindex{slime-tree-for-note}
+@c @fcnindex{slime-tree-for-severity}
+@c @fcnindex{slime-tree-indent-item}
+@c @fcnindex{slime-tree-insert}
+@c @fcnindex{slime-tree-insert-decoration}
+@c @fcnindex{slime-tree-insert-list}
+@c @fcnindex{slime-tree-insert-references}
+@c @fcnindex{slime-tree-leaf-p}
+@c @fcnindex{slime-tree-print-with-references}
+@c @fcnindex{slime-tree-toggle}
+@c @fcnindex{slime-typeout-active-p}
+@c @fcnindex{slime-typeout-message}
+@fcnindex{slime-undefine-function}
+@c @fcnindex{slime-underline-color}
+@fcnindex{slime-unprofile-all}
+@fcnindex{slime-untrace-all}
+@c @fcnindex{slime-update-autodoc-cache}
+@fcnindex{slime-update-connection-list}
+@c @fcnindex{slime-update-indentation} ???
+@c @fcnindex{slime-update-modeline-package}
+@c @fcnindex{slime-urge-bytecode-recompile}
+@c @fcnindex{slime-use-sigint-for-interrupt}
+@c @fcnindex{slime-user-first-name}
+@c @fcnindex{slime-visit-source-path}
+@c @fcnindex{slime-wait-condition}
+@fcnindex{slime-who-binds}
+@fcnindex{slime-who-calls}
+@fcnindex{slime-who-macroexpands}
+@fcnindex{slime-who-references}
+@fcnindex{slime-who-sets}
+@fcnindex{slime-who-specializes}
+@c @fcnindex{slime-window-config-fingerprint}
+@c @fcnindex{slime-with-output-end-mark}
+@c @fcnindex{slime-with-rigid-indentation}
+@c @fcnindex{slime-write-string}
+@c @fcnindex{slime-xref}
+@c @fcnindex{slime-xref-buffer}
+@c @fcnindex{slime-xref-cleanup}
+@end table
+
@bye
Modified: trunk/thirdparty/emacs/slime/doc/texinfo-tabulate.awk
===================================================================
--- trunk/thirdparty/emacs/slime/doc/texinfo-tabulate.awk 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/doc/texinfo-tabulate.awk 2006-11-30 16:32:54 UTC (rev 2092)
@@ -3,6 +3,9 @@
# Format input lines into a multi-column texinfo table.
# Note: does not do texinfo-escaping of the input.
+# This code has been placed in the Public Domain. All warranties
+# are disclaimed.
+
BEGIN {
columns = 3;
printf("@multitable @columnfractions");
Modified: trunk/thirdparty/emacs/slime/hyperspec.el
===================================================================
--- trunk/thirdparty/emacs/slime/hyperspec.el 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/hyperspec.el 2006-11-30 16:32:54 UTC (rev 2092)
@@ -60,6 +60,16 @@
(defvar common-lisp-hyperspec-symbols (make-vector 67 0))
+(defun common-lisp-hyperspec-strip-cl-package (name)
+ (if (string-match "^\\([^:]*\\)::?\\([^:]*\\)$" name)
+ (let ((package-name (match-string 1 name))
+ (symbol-name (match-string 2 name)))
+ (if (member (downcase package-name)
+ '("cl" "common-lisp"))
+ symbol-name
+ name))
+ name))
+
(defun common-lisp-hyperspec (symbol-name)
"View the documentation on SYMBOL-NAME from the Common Lisp HyperSpec.
If SYMBOL-NAME has more than one definition, all of them are displayed with
@@ -73,22 +83,29 @@
Visit http://www.lispworks.com/reference/HyperSpec/ for more information.
If you copy the HyperSpec to another location, customize the variable
`common-lisp-hyperspec-root' to point to that location."
- (interactive (list (let ((symbol-at-point (thing-at-point 'symbol)))
- (if (and symbol-at-point
- (intern-soft (downcase symbol-at-point)
+ (interactive (list (let* ((symbol-at-point (thing-at-point 'symbol))
+ (stripped-symbol
+ (and symbol-at-point
+ (downcase
+ (common-lisp-hyperspec-strip-cl-package
+ symbol-at-point)))))
+ (if (and stripped-symbol
+ (intern-soft stripped-symbol
common-lisp-hyperspec-symbols))
- symbol-at-point
+ stripped-symbol
(completing-read
"Look up symbol in Common Lisp HyperSpec: "
common-lisp-hyperspec-symbols #'boundp
- t symbol-at-point
+ t stripped-symbol
'common-lisp-hyperspec-history)))))
(maplist (lambda (entry)
(browse-url (concat common-lisp-hyperspec-root "Body/" (car entry)))
(if (cdr entry)
(sleep-for 1.5)))
- (let ((symbol (intern-soft (downcase symbol-name)
- common-lisp-hyperspec-symbols)))
+ (let ((symbol (intern-soft
+ (common-lisp-hyperspec-strip-cl-package
+ (downcase symbol-name))
+ common-lisp-hyperspec-symbols)))
(if (and symbol (boundp symbol))
(symbol-value symbol)
(error "The symbol `%s' is not defined in Common Lisp"
@@ -1188,6 +1205,10 @@
(pushnew (cadr entry) (symbol-value symbol) :test 'equal)
(set symbol (cdr entry))))))
'(("c" (22 3 1 1)) ("C: Character" (22 3 1 1))
+ ("%" (22 3 1 2)) ("Percent: Newline" (22 3 1 2))
+ ("&" (22 3 1 3)) ("Ampersand: Fresh-line" (22 3 1 3))
+ ("|" (22 3 1 4)) ("Vertical-Bar: Page" (22 3 1 4))
+ ("~" (22 3 1 5)) ("Tilde: Tilde" (22 3 1 5))
("r" (22 3 2 1)) ("R: Radix" (22 3 2 1))
("d" (22 3 2 2)) ("D: Decimal" (22 3 2-2))
("b" (22 3 2 3)) ("B: Binary" (22 3 2 3))
Modified: trunk/thirdparty/emacs/slime/mkdist.sh
===================================================================
--- trunk/thirdparty/emacs/slime/mkdist.sh 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/mkdist.sh 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,4 +1,8 @@
#!/bin/sh
+
+# This code has been placed in the Public Domain. All warranties
+# are disclaimed.
+
version="1.2"
dist="slime-$version"
Modified: trunk/thirdparty/emacs/slime/nregex.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/nregex.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/nregex.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,13 +1,12 @@
;;;
;;; This code was written by:
;;;
-;;; Lawrence E. Freil <lef(a)nscf.org>
+;;; Lawrence E. Freil <lef(a)freil.com>
;;; National Science Center Foundation
;;; Augusta, Georgia 30909
;;;
-;;; If you modify this code, please comment your modifications
-;;; clearly and inform the author of any improvements so they
-;;; can be incorporated in future releases.
+;;; This program was released into the public domain on 2005-08-31.
+;;; (See the slime-devel mailing list archive for details.)
;;;
;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression
;;; parser.
@@ -26,8 +25,11 @@
(in-package :cl-user)
+;; Renamed to slime-nregex avoid name clashes with other versions of
+;; this file. -- he
+
;;;; CND - 6/3/2001
-(defpackage nregex
+(defpackage slime-nregex
(:use #:common-lisp)
(:export
#:regex
@@ -35,7 +37,7 @@
))
;;;; CND - 6/3/2001
-(in-package :nregex)
+(in-package :slime-nregex)
;;;
;;; First we create a copy of macros to help debug the beast
Modified: trunk/thirdparty/emacs/slime/present.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/present.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/present.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -38,9 +38,24 @@
(presenting-object-1 ,object ,stream ,continue)
(funcall ,continue)))))
+;;; Get pretty printer patches for SBCL
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (handler-bind ((simple-error
+ (lambda (c)
+ (declare (ignore c))
+ (let ((clobber-it (find-restart 'sb-kernel::clobber-it)))
+ (when clobber-it (invoke-restart clobber-it))))))
+ (sb-ext:without-package-locks
+ (swank-backend::with-debootstrapping
+ (load (make-pathname
+ :name "sbcl-pprint-patch"
+ :type "lisp"
+ :directory (pathname-directory swank-loader:*source-directory*)))))))
+
(let ((last-stream nil)
(last-answer nil))
- (defmethod slime-stream-p (stream)
+ (defun slime-stream-p (stream)
"Check if stream is one of the slime streams, since if it isn't we
don't want to present anything"
(if (eq last-stream stream)
@@ -68,8 +83,12 @@
;; layout.
(slime-stream-p (pretty-print::pretty-stream-target stream))))
#+sbcl
- (and (typep stream 'sb-impl::indenting-stream)
- (slime-stream-p (sb-impl::indenting-stream-stream stream)))
+ (or (and (typep stream 'sb-impl::indenting-stream)
+ (slime-stream-p (sb-impl::indenting-stream-stream stream)))
+ (and (typep stream 'sb-pretty::pretty-stream)
+ (fboundp 'sb-pretty::enqueue-annotation)
+ (not *use-dedicated-output-stream*)
+ (slime-stream-p (sb-pretty::pretty-stream-target stream))))
#+allegro
(and (typep stream 'excl:xp-simple-stream)
(slime-stream-p (excl::stream-output-handle stream)))
@@ -97,8 +116,13 @@
(fboundp 'pp::enqueue-annotation))
(pp::enqueue-annotation stream function arg)
(funcall function arg stream nil)))
-#-(or allegro cmu)
+#+sbcl
(defun write-annotation (stream function arg)
+ (if (typep stream 'sb-pretty::pretty-stream)
+ (sb-pretty::enqueue-annotation stream function arg)
+ (funcall function arg stream nil)))
+#-(or allegro cmu sbcl)
+(defun write-annotation (stream function arg)
(funcall function arg stream nil))
(defstruct presentation-record
@@ -144,6 +168,21 @@
(write-annotation stream #'presentation-end record)))
(funcall continue)))
+(defun make-presentations-result (values)
+ ;; Override a function in swank.lisp, so that
+ ;; nested presentations work in the REPL result.
+ (cond
+ ((null values)
+ '(:values ()))
+ (t
+ ;; Do the output ourselves.
+ (fresh-line)
+ (dolist (o values)
+ (presenting-object o *standard-output*
+ (prin1 o))
+ (terpri))
+ '(:suppress-output))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Example: Tell openmcl and cmucl to always present unreadable objects. try (describe 'class)
Added: trunk/thirdparty/emacs/slime/sbcl-pprint-patch.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/sbcl-pprint-patch.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/sbcl-pprint-patch.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -0,0 +1,332 @@
+;; Pretty printer patch for SBCL, which adds the "annotations" feature
+;; required for sending presentations through pretty-printing streams.
+;;
+;; The section marked "Changed functions" and the DEFSTRUCT
+;; PRETTY-STREAM are based on SBCL's pprint.lisp.
+;;
+;; Public domain.
+
+(in-package "SB!PRETTY")
+
+(defstruct (annotation (:include queued-op))
+ (handler (constantly nil) :type function)
+ (record))
+
+
+(defstruct (pretty-stream (:include sb!kernel:ansi-stream
+ (out #'pretty-out)
+ (sout #'pretty-sout)
+ (misc #'pretty-misc))
+ (:constructor make-pretty-stream (target))
+ (:copier nil))
+ ;; Where the output is going to finally go.
+ (target (missing-arg) :type stream)
+ ;; Line length we should format to. Cached here so we don't have to keep
+ ;; extracting it from the target stream.
+ (line-length (or *print-right-margin*
+ (sb!impl::line-length target)
+ default-line-length)
+ :type column)
+ ;; A simple string holding all the text that has been output but not yet
+ ;; printed.
+ (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
+ ;; The index into BUFFER where more text should be put.
+ (buffer-fill-pointer 0 :type index)
+ ;; Whenever we output stuff from the buffer, we shift the remaining noise
+ ;; over. This makes it difficult to keep references to locations in
+ ;; the buffer. Therefore, we have to keep track of the total amount of
+ ;; stuff that has been shifted out of the buffer.
+ (buffer-offset 0 :type posn)
+ ;; The column the first character in the buffer will appear in. Normally
+ ;; zero, but if we end up with a very long line with no breaks in it we
+ ;; might have to output part of it. Then this will no longer be zero.
+ (buffer-start-column (or (sb!impl::charpos target) 0) :type column)
+ ;; The line number we are currently on. Used for *PRINT-LINES*
+ ;; abbreviations and to tell when sections have been split across
+ ;; multiple lines.
+ (line-number 0 :type index)
+ ;; the value of *PRINT-LINES* captured at object creation time. We
+ ;; use this, instead of the dynamic *PRINT-LINES*, to avoid
+ ;; weirdness like
+ ;; (let ((*print-lines* 50))
+ ;; (pprint-logical-block ..
+ ;; (dotimes (i 10)
+ ;; (let ((*print-lines* 8))
+ ;; (print (aref possiblybigthings i) prettystream)))))
+ ;; terminating the output of the entire logical blockafter 8 lines.
+ (print-lines *print-lines* :type (or index null) :read-only t)
+ ;; Stack of logical blocks in effect at the buffer start.
+ (blocks (list (make-logical-block)) :type list)
+ ;; Buffer holding the per-line prefix active at the buffer start.
+ ;; Indentation is included in this. The length of this is stored
+ ;; in the logical block stack.
+ (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
+ ;; Buffer holding the total remaining suffix active at the buffer start.
+ ;; The characters are right-justified in the buffer to make it easier
+ ;; to output the buffer. The length is stored in the logical block
+ ;; stack.
+ (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
+ ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
+ ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
+ ;; cons. Adding things to the queue is basically (setf (cdr head) (list
+ ;; new)) and removing them is basically (pop tail) [except that care must
+ ;; be taken to handle the empty queue case correctly.]
+ (queue-tail nil :type list)
+ (queue-head nil :type list)
+ ;; Block-start queue entries in effect at the queue head.
+ (pending-blocks nil :type list)
+ ;; Queue of annotations to the buffer
+ (annotations-tail nil :type list)
+ (annotations-head nil :type list))
+
+
+(defmacro enqueue (stream type &rest args)
+ (let ((constructor (intern (concatenate 'string
+ "MAKE-"
+ (symbol-name type))
+ "SB-PRETTY")))
+ (once-only ((stream stream)
+ (entry `(,constructor :posn
+ (index-posn
+ (pretty-stream-buffer-fill-pointer
+ ,stream)
+ ,stream)
+ ,@args))
+ (op `(list ,entry))
+ (head `(pretty-stream-queue-head ,stream)))
+ `(progn
+ (if ,head
+ (setf (cdr ,head) ,op)
+ (setf (pretty-stream-queue-tail ,stream) ,op))
+ (setf (pretty-stream-queue-head ,stream) ,op)
+ ,entry))))
+
+;;;
+;;; New helper functions
+;;;
+
+(defun enqueue-annotation (stream handler record)
+ (enqueue stream annotation :handler handler
+ :record record))
+
+(defun re-enqueue-annotation (stream annotation)
+ (let* ((annotation-cons (list annotation))
+ (head (pretty-stream-annotations-head stream)))
+ (if head
+ (setf (cdr head) annotation-cons)
+ (setf (pretty-stream-annotations-tail stream) annotation-cons))
+ (setf (pretty-stream-annotations-head stream) annotation-cons)
+ nil))
+
+(defun re-enqueue-annotations (stream end)
+ (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail)
+ while (and tail (not (eql (car tail) end)))
+ when (annotation-p (car tail))
+ do (re-enqueue-annotation stream (car tail))))
+
+(defun dequeue-annotation (stream &key end-posn)
+ (let ((next-annotation (car (pretty-stream-annotations-tail stream))))
+ (when next-annotation
+ (when (or (not end-posn)
+ (<= (annotation-posn next-annotation) end-posn))
+ (pop (pretty-stream-annotations-tail stream))
+ (unless (pretty-stream-annotations-tail stream)
+ (setf (pretty-stream-annotations-head stream) nil))
+ next-annotation))))
+
+(defun invoke-annotation (stream annotation truncatep)
+ (let ((target (pretty-stream-target stream)))
+ (funcall (annotation-handler annotation)
+ (annotation-record annotation)
+ target
+ truncatep)))
+
+(defun output-buffer-with-annotations (stream end)
+ (let ((target (pretty-stream-target stream))
+ (buffer (pretty-stream-buffer stream))
+ (end-posn (index-posn end stream))
+ (start 0))
+ (loop
+ for annotation = (dequeue-annotation stream :end-posn end-posn)
+ while annotation
+ do
+ (let ((annotation-index (posn-index (annotation-posn annotation)
+ stream)))
+ (when (> annotation-index start)
+ (write-string buffer target :start start
+ :end annotation-index)
+ (setf start annotation-index))
+ (invoke-annotation stream annotation nil)))
+ (when (> end start)
+ (write-string buffer target :start start :end end))))
+
+(defun flush-annotations (stream end truncatep)
+ (let ((end-posn (index-posn end stream)))
+ (loop
+ for annotation = (dequeue-annotation stream :end-posn end-posn)
+ while annotation
+ do (invoke-annotation stream annotation truncatep))))
+
+;;;
+;;; Changed functions
+;;;
+
+(defun maybe-output (stream force-newlines-p)
+ (declare (type pretty-stream stream))
+ (let ((tail (pretty-stream-queue-tail stream))
+ (output-anything nil))
+ (loop
+ (unless tail
+ (setf (pretty-stream-queue-head stream) nil)
+ (return))
+ (let ((next (pop tail)))
+ (etypecase next
+ (newline
+ (when (ecase (newline-kind next)
+ ((:literal :mandatory :linear) t)
+ (:miser (misering-p stream))
+ (:fill
+ (or (misering-p stream)
+ (> (pretty-stream-line-number stream)
+ (logical-block-section-start-line
+ (first (pretty-stream-blocks stream))))
+ (ecase (fits-on-line-p stream
+ (newline-section-end next)
+ force-newlines-p)
+ ((t) nil)
+ ((nil) t)
+ (:dont-know
+ (return))))))
+ (setf output-anything t)
+ (output-line stream next)))
+ (indentation
+ (unless (misering-p stream)
+ (set-indentation stream
+ (+ (ecase (indentation-kind next)
+ (:block
+ (logical-block-start-column
+ (car (pretty-stream-blocks stream))))
+ (:current
+ (posn-column
+ (indentation-posn next)
+ stream)))
+ (indentation-amount next)))))
+ (block-start
+ (ecase (fits-on-line-p stream (block-start-section-end next)
+ force-newlines-p)
+ ((t)
+ ;; Just nuke the whole logical block and make it look like one
+ ;; nice long literal. (But don't nuke annotations.)
+ (let ((end (block-start-block-end next)))
+ (expand-tabs stream end)
+ (re-enqueue-annotations stream end)
+ (setf tail (cdr (member end tail)))))
+ ((nil)
+ (really-start-logical-block
+ stream
+ (posn-column (block-start-posn next) stream)
+ (block-start-prefix next)
+ (block-start-suffix next)))
+ (:dont-know
+ (return))))
+ (block-end
+ (really-end-logical-block stream))
+ (tab
+ (expand-tabs stream next))
+ (annotation
+ (re-enqueue-annotation stream next))))
+ (setf (pretty-stream-queue-tail stream) tail))
+ output-anything))
+
+(defun output-line (stream until)
+ (declare (type pretty-stream stream)
+ (type newline until))
+ (let* ((target (pretty-stream-target stream))
+ (buffer (pretty-stream-buffer stream))
+ (kind (newline-kind until))
+ (literal-p (eq kind :literal))
+ (amount-to-consume (posn-index (newline-posn until) stream))
+ (amount-to-print
+ (if literal-p
+ amount-to-consume
+ (let ((last-non-blank
+ (position #\space buffer :end amount-to-consume
+ :from-end t :test #'char/=)))
+ (if last-non-blank
+ (1+ last-non-blank)
+ 0)))))
+ (output-buffer-with-annotations stream amount-to-print)
+ (flush-annotations stream amount-to-consume nil)
+ (let ((line-number (pretty-stream-line-number stream)))
+ (incf line-number)
+ (when (and (not *print-readably*)
+ (pretty-stream-print-lines stream)
+ (>= line-number (pretty-stream-print-lines stream)))
+ (write-string " .." target)
+ (flush-annotations stream
+ (pretty-stream-buffer-fill-pointer stream)
+ t)
+ (let ((suffix-length (logical-block-suffix-length
+ (car (pretty-stream-blocks stream)))))
+ (unless (zerop suffix-length)
+ (let* ((suffix (pretty-stream-suffix stream))
+ (len (length suffix)))
+ (write-string suffix target
+ :start (- len suffix-length)
+ :end len))))
+ (throw 'line-limit-abbreviation-happened t))
+ (setf (pretty-stream-line-number stream) line-number)
+ (write-char #\newline target)
+ (setf (pretty-stream-buffer-start-column stream) 0)
+ (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ (block (first (pretty-stream-blocks stream)))
+ (prefix-len
+ (if literal-p
+ (logical-block-per-line-prefix-end block)
+ (logical-block-prefix-length block)))
+ (shift (- amount-to-consume prefix-len))
+ (new-fill-ptr (- fill-ptr shift))
+ (new-buffer buffer)
+ (buffer-length (length buffer)))
+ (when (> new-fill-ptr buffer-length)
+ (setf new-buffer
+ (make-string (max (* buffer-length 2)
+ (+ buffer-length
+ (floor (* (- new-fill-ptr buffer-length)
+ 5)
+ 4)))))
+ (setf (pretty-stream-buffer stream) new-buffer))
+ (replace new-buffer buffer
+ :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
+ (replace new-buffer (pretty-stream-prefix stream)
+ :end1 prefix-len)
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (incf (pretty-stream-buffer-offset stream) shift)
+ (unless literal-p
+ (setf (logical-block-section-column block) prefix-len)
+ (setf (logical-block-section-start-line block) line-number))))))
+
+(defun output-partial-line (stream)
+ (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ (tail (pretty-stream-queue-tail stream))
+ (count
+ (if tail
+ (posn-index (queued-op-posn (car tail)) stream)
+ fill-ptr))
+ (new-fill-ptr (- fill-ptr count))
+ (buffer (pretty-stream-buffer stream)))
+ (when (zerop count)
+ (error "Output-partial-line called when nothing can be output."))
+ (output-buffer-with-annotations stream count)
+ (incf (pretty-stream-buffer-start-column stream) count)
+ (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (incf (pretty-stream-buffer-offset stream) count)))
+
+(defun force-pretty-output (stream)
+ (maybe-output stream nil)
+ (expand-tabs stream nil)
+ (re-enqueue-annotations stream nil)
+ (output-buffer-with-annotations stream
+ (pretty-stream-buffer-fill-pointer stream)))
+
\ No newline at end of file
Modified: trunk/thirdparty/emacs/slime/slime.el
===================================================================
--- trunk/thirdparty/emacs/slime/slime.el 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/slime.el 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,8 +1,8 @@
-;;; -*- mode: emacs-lisp; mode: outline-minor; outline-regexp: ";;;;+"; indent-tabs-mode: nil -*-
-;; slime.el -- Superior Lisp Interaction Mode for Emacs
+;;; slime.el -- Superior Lisp Interaction Mode for Emacs
+;;
;;;; License
;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller
-;; Copyright (C) 2004 Luke Gorrie, Helmut Eller
+;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@@ -65,22 +65,40 @@
(require 'easymenu)
(defvar slime-use-autodoc-mode nil
- "When non-nil always enabled slime-autodoc-mode in slime-mode.")
+ "When non-nil always enable slime-autodoc-mode in slime-mode.")
-(defun* slime-setup (&key autodoc typeout-frame)
+(defvar slime-use-highlight-edits-mode nil
+ "When non-nil always enable slime-highlight-edits-mode in slime-mode")
+
+(defvar slime-highlight-compiler-notes t
+ "When non-nil highlight buffers with compilation notes, warnings and errors.")
+
+(defun* slime-setup (&key autodoc typeout-frame highlight-edits)
"Setup Emacs so that lisp-mode buffers always use SLIME."
- (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)
+ (when (member 'lisp-mode slime-lisp-modes)
+ (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook))
+ (when (member 'scheme-mode slime-lisp-modes)
+ (add-hook 'scheme-mode-hook 'slime-scheme-mode-hook))
(when typeout-frame
(add-hook 'slime-connected-hook 'slime-ensure-typeout-frame))
- (setq slime-use-autodoc-mode autodoc))
+ (setq slime-use-autodoc-mode autodoc)
+ (setq slime-use-highlight-edits-mode highlight-edits))
-(defun slime-lisp-mode-hook ()
+(defun slime-shared-lisp-mode-hook ()
(slime-mode 1)
- (set (make-local-variable 'lisp-indent-function)
- 'common-lisp-indent-function)
(when slime-use-autodoc-mode
- (slime-autodoc-mode 1)))
+ (slime-autodoc-mode 1))
+ (when slime-use-highlight-edits-mode
+ (slime-highlight-edits-mode 1)))
+(defun slime-lisp-mode-hook ()
+ (slime-shared-lisp-mode-hook)
+ (set (make-local-variable 'lisp-indent-function)
+ 'common-lisp-indent-function))
+
+(defun slime-scheme-mode-hook ()
+ (slime-shared-lisp-mode-hook))
+
(eval-and-compile
(defvar slime-path
(let ((path (or (locate-library "slime") load-file-name)))
@@ -90,6 +108,22 @@
The default value is automatically computed from the location of the
Emacs Lisp package."))
+(eval-and-compile
+ (defun slime-changelog-date ()
+ "Return the datestring of the latest entry in the ChangeLog file.
+Return nil if the ChangeLog file cannot be found."
+ (let ((changelog (concat slime-path "ChangeLog")))
+ (if (file-exists-p changelog)
+ (with-temp-buffer
+ (insert-file-contents changelog nil 0 100)
+ (goto-char (point-min))
+ (symbol-name (read (current-buffer))))
+ nil))))
+
+(defvar slime-protocol-version nil)
+(setq slime-protocol-version
+ (eval-when-compile (slime-changelog-date)))
+
;;;; Customize groups
;;
@@ -138,14 +172,6 @@
:prefix "slime-"
:group 'slime)
-;; XXX How can we get rid of this? I think only CMUCL needs it.
-;; -luke (17/Jul/2004)
-(defcustom slime-multiprocessing nil
- "Instruct the Lisp system to initialize multiprocessing on startup.
-You may need to enable this in order to use threads with SLIME."
- :type 'boolean
- :group 'slime-lisp)
-
(defcustom slime-backend "swank-loader.lisp"
"The name of the Lisp file that loads the Swank server.
This name is interpreted relative to the directory containing
@@ -158,17 +184,47 @@
:type 'hook
:group 'slime-lisp)
-(defcustom slime-translate-to-lisp-filename-function 'identity
- "Function to use for translating Emacs filenames to Lisp filenames.
-The function recieves a string as argument and should return string.
-No suitable functions are ready-made, you have to write one yourself."
- :type 'function
+(defcustom slime-filename-translations nil
+ "Alist of mappings between machine names 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 'list
:group 'slime-lisp)
-(defcustom slime-translate-from-lisp-filename-function 'identity
- "Function to use for translating Lisp filenames to Emacs filenames.
-See also `slime-translate-to-lisp-filename-function'."
- :type 'function
+(defcustom slime-enable-evaluate-in-emacs nil
+ "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs.
+The default is nil, as this feature can be a security risk."
+ :type '(boolean)
:group 'slime-lisp)
;;;;; slime-mode
@@ -182,13 +238,13 @@
"Function to call when edit-definition fails to find the source itself.
The function is called with the definition name, a string, as its argument.
-If you want to fallback on TAGS you can set this to `find-tags' or
+If you want to fallback on TAGS you can set this to `find-tag' or
`slime-edit-definition-with-etags'."
:type 'symbol
:group 'slime-mode-mode
:options '(nil
slime-edit-definition-with-etags
- find-tags))
+ find-tag))
(defcustom slime-compilation-finished-hook 'slime-maybe-list-compiler-notes
"Hook called with a list of compiler notes after a compilation."
@@ -198,18 +254,46 @@
slime-list-compiler-notes
slime-maybe-show-xrefs-for-notes))
+(defcustom slime-goto-first-note-after-compilation nil
+ "When T next-note will always goto to the first note in a
+final, no matter where the point is."
+ :group 'slime-mode
+ :type 'boolean)
+
(defcustom slime-complete-symbol-function 'slime-complete-symbol*
- "Function to perform symbol completion."
+ "*Function to perform symbol completion."
:group 'slime-mode
:type '(choice (const :tag "Simple" slime-simple-complete-symbol)
(const :tag "Compound" slime-complete-symbol*)
(const :tag "Fuzzy" slime-fuzzy-complete-symbol)))
+(defcustom slime-when-complete-filename-expand nil
+ "Use comint-replace-by-expanded-filename instead of comint-dynamic-complete-as-filename to complete file names"
+ :group 'slime-mode
+ :type 'boolean)
+
(defcustom slime-complete-symbol*-fancy nil
"Use information from argument lists for DWIM'ish symbol completion."
:group 'slime-mode
:type 'boolean)
+(defcustom slime-fuzzy-completion-in-place nil
+ "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 comletitions.
+\(NOTE: currently it's rounded up the nearest second)"
+ :group 'slime-mode
+ :type 'integer)
+
(defcustom slime-space-information-p t
"Have the SPC key offer arglist information."
:type 'boolean
@@ -357,6 +441,43 @@
:type '(character)
:group 'slime-repl)
+(defcustom slime-repl-enable-presentations
+ (cond ((and (not (featurep 'xemacs)) (= emacs-major-version 20))
+ ;; mouseable text sucks in Emacs 20
+ nil)
+ (t t))
+ "*Should we enable presentations"
+ :type '(boolean)
+ :group 'slime-repl)
+
+(defcustom slime-repl-only-save-lisp-buffers t
+ "When T we only attempt to save lisp-mode file buffers. When
+ NIL slime will attempt to save all buffers (as per
+ save-some-buffers). This applies to all ASDF related repl
+ shortcuts."
+ :type '(boolean)
+ :group 'slime-repl)
+
+(defcustom slime-repl-return-behaviour :send-if-complete
+ "Keyword specifying how slime-repl-return behaves when the
+ point is on a lisp expression (as opposed to being on a
+ previous output).
+
+Currently only two values are supported:
+
+:send-if-complete - If the current expression is complete, as per
+slime-input-complete-p, it is sent to the underlying lisp,
+otherwise a newline is inserted. The current value of (point) has
+no effect.
+
+:send-only-if-after-complete - If the current expression is complete
+and point is after the expression it is sent, otherwise a newline
+is inserted."
+ :type '(choice (const :tag "Send if complete" :value :send-if-complete)
+ (const :tag "Send only if after complete" :value :send-only-if-after-complete))
+ :group 'slime-repl)
+
+
(defface slime-repl-prompt-face
(if (slime-face-inheritance-possible-p)
'((t (:inherit font-lock-keyword-face)))
@@ -377,13 +498,15 @@
(defface slime-repl-output-mouseover-face
- (if (slime-face-inheritance-possible-p)
- '((t
- (:box
- (:line-width 1 :color "black" :style released-button)
- :inherit
- (slime-repl-inputed-output-face))))
- '((t (:box (:line-width 1 :color "black")))))
+ (if (featurep 'xemacs)
+ '((t (:bold t)))
+ (if (slime-face-inheritance-possible-p)
+ '((t
+ (:box
+ (:line-width 1 :color "black" :style released-button)
+ :inherit
+ (slime-repl-inputed-output-face))))
+ '((t (:box (:line-width 1 :color "black"))))))
"Face for Lisp output in the SLIME REPL, when the mouse hovers over it"
:group 'slime-repl)
@@ -404,10 +527,76 @@
"Face for the result of an evaluation in the SLIME REPL."
:group 'slime-repl)
+(defcustom slime-repl-history-file "~/.slime-history.eld"
+ "File to save the persistent REPL history to."
+ :type 'string
+ :group 'slime-repl)
+
+(defcustom slime-repl-history-size 200
+ "*Maximum number of lines for persistent REPL history."
+ :type 'integer
+ :group 'slime-repl)
+
;;;; Minor modes
+;;;; slime-target-buffer-fuzzy-completions-mode
+;;;; NOTE: this mode has to be able to override key mappings in slime-mode
+
+(defun mimic-key-bindings (from-keymap to-keymap bindings-or-operation operation)
+ "Iterate on BINDINGS-OR-OPERATION. If an element is a symbol then
+try to look it up (as an operation) in FROM-KEYMAP. Non symbols are taken
+as default key bindings when none to be mimiced was found in FROM-KEYMAP.
+Set the resulting list of keys in TO-KEYMAP to OPERATION."
+ (let ((mimic-keys nil)
+ (direct-keys nil))
+ (dolist (key-or-operation bindings-or-operation)
+ (if (symbolp key-or-operation)
+ (setf mimic-keys (append mimic-keys (where-is-internal key-or-operation from-keymap nil t)))
+ (push key-or-operation direct-keys)))
+ (dolist (key (or mimic-keys direct-keys))
+ (define-key to-keymap key operation))))
+
+(defvar slime-target-buffer-fuzzy-completions-map
+ (let* ((map (make-sparse-keymap)))
+ (flet ((remap (keys to)
+ (mimic-key-bindings global-map map keys to)))
+
+ (remap (list 'keyboard-quit (kbd "C-g")) 'slime-fuzzy-abort)
+
+ (remap (list 'slime-fuzzy-indent-and-complete-symbol
+ 'slime-indent-and-complete-symbol
+ (kbd "<tab>"))
+ 'slime-fuzzy-select-or-update-completions)
+ (remap (list 'previous-line (kbd "<up>")) 'slime-fuzzy-prev)
+ (remap (list 'next-line (kbd "<down>")) 'slime-fuzzy-next)
+ (remap (list 'isearch-forward (kbd "C-s"))
+ (lambda ()
+ (interactive)
+ (select-window (get-buffer-window (slime-get-fuzzy-buffer)))
+ (call-interactively 'isearch-forward)))
+
+ ;; some unconditional direct bindings
+ (dolist (key (list (kbd "RET") (kbd "<SPC>") "(" ")" "[" "]"))
+ (define-key map key '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.")
+
+(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"))
+
+
;;;;; slime-mode
-
(define-minor-mode slime-mode
"\\<slime-mode-map>\
SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode).
@@ -452,7 +641,7 @@
(defun slime-update-modeline-package ()
(ignore-errors
(when (and slime-update-modeline-package
- (eq major-mode 'lisp-mode)
+ (memq major-mode slime-lisp-modes)
slime-mode)
(let ((package (slime-current-package)))
(when package
@@ -526,7 +715,7 @@
"Return t if the region from START to END contains a complete sexp."
(save-excursion
(goto-char start)
- (cond ((looking-at "\\s *['`#]?(")
+ (cond ((looking-at "\\s *['`#]?[(\"]")
(ignore-errors
(save-restriction
(narrow-to-region start end)
@@ -587,6 +776,7 @@
("\C-\M-x" slime-eval-defun)
(":" slime-interactive-eval :prefixed t :sldb t)
("\C-e" slime-interactive-eval :prefixed t :sldb t :inferior t)
+ ("\C-y" slime-call-defun :prefixed t)
("E" slime-edit-value :prefixed t :sldb t :inferior t)
("\C-z" slime-switch-to-output-buffer :prefixed t :sldb t)
("\C-b" slime-interrupt :prefixed t :inferior t :sldb t)
@@ -682,7 +872,7 @@
(define-key slime-doc-map (string key) command)
(unless (equal key ?h) ; But don't bind C-h
(let ((modified (slime-control-modified-char key)))
- (define-key slime-doc-map (string modified) command)))))
+ (define-key slime-doc-map (vector modified) command)))))
;; C-c C-d is the prefix for the doc map.
(slime-define-key "\C-d" slime-doc-map :prefixed t :inferior t)
;; Who-xref
@@ -692,14 +882,14 @@
;; We bind both unmodified and with control.
(define-key slime-who-map (string key) command)
(let ((modified (slime-control-modified-char key)))
- (define-key slime-who-map (string modified) command))))
+ (define-key slime-who-map (vector modified) command))))
;; C-c C-w is the prefix for the who-xref map.
(slime-define-key "\C-w" slime-who-map :prefixed t :inferior t))
(defun slime-control-modified-char (char)
"Return the control-modified version of CHAR."
;; Maybe better to just bitmask it?
- (car (read-from-string (format "?\\C-%c" char))))
+ (read (format "?\\C-%c" char)))
(slime-init-keymaps)
@@ -723,7 +913,8 @@
[ "Eval Region" slime-eval-region ,C ]
[ "Scratch Buffer" slime-scratch ,C ]
[ "Interactive Eval..." slime-interactive-eval ,C ]
- [ "Edit Lisp Value..." slime-edit-value ,C ])
+ [ "Edit Lisp Value..." slime-edit-value ,C ]
+ [ "Call Defun" slime-call-defun ,C ])
("Debugging"
[ "Macroexpand Once..." slime-macroexpand-1 ,C ]
[ "Macroexpand All..." slime-macroexpand-all ,C ]
@@ -774,8 +965,7 @@
[ "Interrupt Command" slime-interrupt ,C ]
[ "Abort Async. Command" slime-quit ,C ]
[ "Sync Package & Directory" slime-sync-package-and-default-directory ,C]
- [ "Set Package in REPL" slime-repl-set-package ,C]
- )))
+ [ "Set Package in REPL" slime-repl-set-package ,C])))
(defvar slime-repl-easy-menu
(let ((C '(slime-connected-p)))
@@ -789,7 +979,8 @@
[ "Goto Previous Prompt " slime-repl-previous-prompt t ]
[ "Goto Next Prompt " slime-repl-next-prompt t ]
[ "Clear Last Output" slime-repl-clear-output t ]
- [ "Clear Buffer " slime-repl-clear-buffer t ])))
+ [ "Clear Buffer " slime-repl-clear-buffer t ]
+ [ "Kill Current Input" slime-repl-kill-input t ])))
(defvar slime-sldb-easy-menu
(let ((C '(slime-connected-p)))
@@ -813,7 +1004,10 @@
("Invoke Restart"
[ "Continue" sldb-continue ,C ]
[ "Abort" sldb-abort ,C ]
- [ "Step" sldb-step ,C ])
+ [ "Step" sldb-step ,C ]
+ [ "Step next" sldb-next ,C ]
+ [ "Step out" sldb-out ,C ]
+ )
"--"
[ "Quit (throw)" sldb-quit ,C ]
[ "Break With Default Debugger" sldb-break-with-default-debugger ,C ])))
@@ -829,6 +1023,8 @@
(defun slime-repl-add-easy-menu ()
(easy-menu-define menubar-slime-repl slime-repl-mode-map
"REPL" slime-repl-easy-menu)
+ (easy-menu-define menubar-slime slime-repl-mode-map
+ "SLIME" slime-easy-menu)
(easy-menu-add slime-repl-easy-menu 'slime-repl-mode-map)))
(add-hook 'sldb-mode-hook
@@ -838,6 +1034,19 @@
(easy-menu-add slime-sldb-easy-menu 'sldb-mode-map)))
+;;;; Emacs compatibility
+
+(or (fboundp 'add-local-hook)
+ (defun add-local-hook (hook function &optional append)
+ (make-local-hook hook)
+ (add-hook hook function append t)))
+
+(or (fboundp 'remove-local-hook)
+ (defun remove-local-hook (hook function)
+ (if (local-variable-p hook (current-buffer))
+ (remove-hook hook function t))))
+
+
;;;; Setup initial `slime-mode' hooks
(make-variable-buffer-local
@@ -849,24 +1058,19 @@
"Execute all functions in `slime-pre-command-actions', then NIL it."
(dolist (undo-fn slime-pre-command-actions)
(ignore-errors (funcall undo-fn)))
- (setq slime-pre-command-actions nil)
- (slime-presentation-command-hook))
+ (setq slime-pre-command-actions nil))
(defun slime-post-command-hook ()
- (when (and slime-mode (slime-connected-p))
- (slime-process-available-input))
(when (null pre-command-hook) ; sometimes this is lost
- (add-hook 'pre-command-hook 'slime-pre-command-hook)))
+ (add-hook 'pre-command-hook 'slime-pre-command-hook)))
(defun slime-setup-command-hooks ()
"Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'."
- (make-local-hook 'pre-command-hook)
- (make-local-hook 'post-command-hook)
- (add-hook 'pre-command-hook 'slime-pre-command-hook)
- (add-hook 'post-command-hook 'slime-post-command-hook))
+ (add-local-hook 'pre-command-hook 'slime-pre-command-hook)
+ (add-local-hook 'post-command-hook 'slime-post-command-hook)
+ (when slime-repl-enable-presentations
+ (add-local-hook 'after-change-functions 'slime-after-change-function)))
-(add-hook 'slime-mode-hook 'slime-setup-command-hooks)
-
;;;; Framework'ey bits
;;;
@@ -1025,7 +1229,7 @@
(completing-read prompt (slime-bogus-completion-alist
(slime-eval
`(swank:list-all-package-names t)))
- nil nil initial-value)))
+ nil t initial-value)))
;; Interface
(defun slime-read-symbol-name (prompt &optional query)
@@ -1092,16 +1296,19 @@
"The window config \"fingerprint\" after displaying the buffer."))
;; Interface
-(defun* slime-get-temp-buffer-create (name &key mode noselectp)
+(defun* slime-get-temp-buffer-create (name &key mode noselectp reusep)
"Return a fresh temporary buffer called NAME in MODE.
The buffer also uses the minor-mode `slime-temp-buffer-mode'. Pressing
`q' in the buffer will restore the window configuration to the way it
is when the buffer was created, i.e. when this function was called.
-If NOSELECTP is true then the buffer is shown by `display-buffer',
-otherwise it is shown and selected by `pop-to-buffer'."
+If NOSELECTP is true, then the buffer is shown by `display-buffer',
+otherwise it is shown and selected by `pop-to-buffer'.
+
+If REUSEP is true and a buffer does already exist with name NAME,
+then the buffer will be reused instead of being killed."
(let ((window-config (current-window-configuration)))
- (when (get-buffer name) (kill-buffer name))
+ (when (and (get-buffer name) (not reusep)) (kill-buffer name))
(with-current-buffer (get-buffer-create name)
(when mode (funcall mode))
(slime-temp-buffer-mode 1)
@@ -1114,14 +1321,17 @@
(current-buffer))))
;; Interface
-(defmacro* slime-with-output-to-temp-buffer ((name &optional mode)
+(defmacro* slime-with-output-to-temp-buffer ((name &key mode reusep)
package &rest body)
"Similar to `with-output-to-temp-buffer'.
Also saves the window configuration, and inherits the current
`slime-connection' in a buffer-local variable."
`(let ((connection (slime-connection))
- (standard-output (slime-get-temp-buffer-create ,name :mode ',mode)))
- (prog1 (with-current-buffer standard-output ,@body)
+ (standard-output (slime-get-temp-buffer-create ,name :mode ',mode
+ :reusep ,reusep)))
+ (prog1 (with-current-buffer standard-output
+ ;; set explicitely to NIL in case the buffer got reused. (REUSEP)
+ (let ((buffer-read-only nil)) ,@body))
(with-current-buffer standard-output
(setq slime-buffer-connection connection)
(setq slime-buffer-package ,package)
@@ -1140,12 +1350,15 @@
;; Interface
(defun slime-temp-buffer-quit ()
- "Kill the current buffer and restore the old window configuration.
-See `slime-temp-buffer-dismiss'."
+ "Kill the current (temp) buffer without asking. To restore the
+window configuration without killing the buffer see
+`slime-dismiss-temp-buffer'."
(interactive)
- (let ((buf (current-buffer)))
- (slime-dismiss-temp-buffer)
- (kill-buffer buf)))
+ (let* ((buffer (current-buffer))
+ (window (get-buffer-window buffer)))
+ (kill-buffer buffer)
+ (when window
+ (delete-window window))))
;; Interface
(defun slime-dismiss-temp-buffer ()
@@ -1181,16 +1394,64 @@
(defun slime-to-lisp-filename (filename)
"Translate the string FILENAME to a Lisp filename.
-See `slime-translate-to-lisp-filename-function'."
- (funcall slime-translate-to-lisp-filename-function
- ;; expand-file-name so that Lisp doesn't see ~foo/bar, etc
+See `slime-filename-translations'."
+ (funcall (first (slime-find-filename-translators (slime-machine-instance)))
(expand-file-name filename)))
(defun slime-from-lisp-filename (filename)
"Translate the Lisp filename FILENAME to an Emacs filename.
-See `slime-translate-from-lisp-filename-function'."
- (funcall slime-translate-from-lisp-filename-function filename))
+See `slime-filename-translations'."
+ (funcall (second (slime-find-filename-translators (slime-machine-instance)))
+ filename))
+(defun slime-find-filename-translators (hostname)
+ (cond ((and hostname slime-filename-translations)
+ (or (cdr (assoc-if (lambda (regexp) (string-match regexp hostname))
+ slime-filename-translations))
+ (error "No filename-translations for hostname: %s" hostname)))
+ (t (list #'identity #'identity))))
+
+(defun slime-make-tramp-file-name (username remote-host lisp-filename)
+ "Old (with multi-hops) tramp compatability function"
+ (require 'tramp)
+ (if (boundp 'tramp-multi-methods)
+ (tramp-make-tramp-file-name nil nil
+ username
+ remote-host
+ lisp-filename)
+ (tramp-make-tramp-file-name nil
+ username
+ remote-host
+ lisp-filename)))
+
+(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)))))
+
;;;; Starting SLIME
;;;
@@ -1202,46 +1463,94 @@
(defvar slime-inferior-lisp-program-history '()
"History list of command strings. Used by `slime'.")
-;; XXX: inferior-lisp-program isn't preloaded in XEmacs. maybe we
-;; should use something else.
+;; We no longer load inf-lisp, but we use this variable for backward
+;; compatibility.
(defvar inferior-lisp-program "lisp"
"*Program name for invoking an inferior Lisp with for Inferior Lisp mode.")
-(defun slime (&optional command buffer coding-system)
+(defun slime (&optional command coding-system)
"Start an inferior^_superior Lisp and connect to its Swank server."
- (interactive (list (if current-prefix-arg
- (read-string "Run lisp: " inferior-lisp-program
- 'slime-inferior-lisp-program-history))
- "*inferior-lisp*"
- (if (eq 16 (prefix-numeric-value current-prefix-arg))
- (read-coding-system "set slime-coding-system: "
- slime-net-coding-system))))
- (let ((command (or (slime-find-lisp-implementation command)
- inferior-lisp-program))
- (buffer (or buffer "*inferior-lisp*"))
- (coding-system (or coding-system slime-net-coding-system)))
- (let ((symbolic-lisp-name (slime-symbolic-lisp-name-p command)))
- (slime-check-coding-system coding-system)
- (setq slime-net-coding-system coding-system)
- (when (or (not (slime-bytecode-stale-p))
- (slime-urge-bytecode-recompile))
- (let ((proc (slime-maybe-start-lisp command buffer)))
- (slime-inferior-connect proc nil symbolic-lisp-name)
- (pop-to-buffer (process-buffer proc)))))))
+ (interactive)
+ (apply #'slime-start (slime-read-interactive-args)))
-(defun slime-connect (host port &optional kill-old-p symbolic-lisp-name)
+(defun slime-read-interactive-args ()
+ "Return the list of args which should be passed to `slime-start'.
+
+The rules for selecting the arguments are rather complicated:
+
+- In the most common case, i.e. if there's no prefix-arg in
+ effect and if `slime-lisp-implementations' is nil, use
+ `inferior-lisp-program' as fallback.
+
+- If the table `slime-lisp-implementations' is non-nil use the
+ implementation with name `slime-default-lisp' or if that's nil
+ the first entry in the table.
+
+- If the prefix-arg is `-', prompt for one of the registered
+ lisps.
+
+- If the prefix-arg is positive, read the command to start the
+ process."
+ (let ((table slime-lisp-implementations))
+ (cond ((not current-prefix-arg)
+ (cond (table
+ (slime-lookup-lisp-implementation
+ table (or slime-default-lisp (car (first table)))))
+ (t
+ (destructuring-bind (program &rest args)
+ (split-string inferior-lisp-program)
+ (list :program program :program-args args)))))
+ ((eq current-prefix-arg '-)
+ (let ((key (completing-read
+ "Lisp name: " (mapcar (lambda (x)
+ (list (symbol-name (car x))))
+ table)
+ nil t)))
+ (slime-lookup-lisp-implementation table (intern key))))
+ (t
+ (destructuring-bind (program &rest program-args)
+ (split-string (read-string
+ "Run lisp: " inferior-lisp-program
+ 'slime-inferior-lisp-program-history))
+ (let ((coding-system
+ (if (eq 16 (prefix-numeric-value current-prefix-arg))
+ (read-coding-system "set slime-coding-system: "
+ slime-net-coding-system)
+ slime-net-coding-system)))
+ (list :program program :program-args program-args
+ :coding-system coding-system)))))))
+
+(defun slime-lookup-lisp-implementation (table name)
+ (destructuring-bind (name (prog &rest args) &rest keys) (assoc name table)
+ (list* :name name :program prog :program-args args keys)))
+
+(defun* slime-start (&key (program inferior-lisp-program) program-args
+ (coding-system slime-net-coding-system)
+ (init 'slime-init-command)
+ name
+ (buffer "*inferior-lisp*"))
+ (let ((args (list :program program :program-args program-args :buffer buffer
+ :coding-system coding-system :init init :name name)))
+ (slime-check-coding-system coding-system)
+ (when (or (not (slime-bytecode-stale-p))
+ (slime-urge-bytecode-recompile))
+ (let ((proc (slime-maybe-start-lisp program program-args buffer)))
+ (slime-inferior-connect proc args)
+ (pop-to-buffer (process-buffer proc))))))
+
+(defun slime-connect (host port &optional coding-system)
"Connect to a running Swank server."
- (interactive (list (read-from-minibuffer "Host: " "127.0.0.1")
- (read-from-minibuffer "Port: " "4005" nil t)
- (if (null slime-net-processes)
- t
- (y-or-n-p "Close old connections first? "))))
- (slime-check-coding-system)
- (when kill-old-p (slime-disconnect))
- (message "Connecting to Swank on port %S.." port)
- (let* ((process (slime-net-connect host port))
- (slime-dispatching-connection process))
- (slime-setup-connection process symbolic-lisp-name)))
+ (interactive (list (read-from-minibuffer "Host: " slime-lisp-host)
+ (read-from-minibuffer "Port: " "4005" nil t)))
+ (when (and (interactive-p) slime-net-processes
+ (y-or-n-p "Close old connections first? "))
+ (slime-disconnect))
+ (let ((coding-system (or coding-system slime-net-coding-system)))
+ (slime-check-coding-system coding-system)
+ (message "Connecting to Swank on port %S.." port)
+ (let* ((process (slime-net-connect host port coding-system))
+ (slime-dispatching-connection process))
+ (slime-setup-connection process))))
(defun slime-start-and-load (filename &optional package)
"Start Slime, if needed, load the current file and set the package."
@@ -1342,63 +1651,76 @@
;;; Starting the inferior Lisp and loading Swank:
-(defun slime-maybe-start-lisp (command buffername)
- "Start an inferior lisp. Instruct it to load Swank."
- (cond ((not (comint-check-proc buffername))
- (slime-start-lisp command buffername (slime-init-command)))
- ((y-or-n-p "Create an additional *inferior-lisp*? ")
- (slime-start-lisp command (generate-new-buffer-name buffername)
- (slime-init-command)))
- (t
- (when-let (conn (find (get-buffer-process buffername)
- slime-net-processes
+(defun slime-maybe-start-lisp (program program-args buffer)
+ "Return a new or existing inferior lisp process."
+ (cond ((not (comint-check-proc buffer))
+ (slime-start-lisp program program-args buffer))
+ ((slime-reinitialize-inferior-lisp-p program program-args buffer)
+ (when-let (conn (find (get-buffer-process buffer) slime-net-processes
:key #'slime-inferior-process))
(slime-net-close conn))
- (get-buffer-process buffername))))
+ (get-buffer-process buffer))
+ (t (slime-start-lisp program program-args
+ (generate-new-buffer-name buffer)))))
-(defun slime-init-command ()
- "Return a string to initialize Lisp."
- (let ((swank (slime-to-lisp-filename (if (file-name-absolute-p slime-backend)
- slime-backend
- (concat slime-path slime-backend))))
- (mp (if slime-multiprocessing "(swank:startup-multiprocessing)\n" "")))
- (format "(load %S :verbose t)\n%s" swank mp)))
+(defun slime-reinitialize-inferior-lisp-p (program program-args buffer)
+ (let ((args (slime-inferior-lisp-args (get-buffer-process buffer))))
+ (and (equal (plist-get args :program) program)
+ (equal (plist-get args :program-args) program-args)
+ (not (y-or-n-p "Create an additional *inferior-lisp*? ")))))
-(defun slime-start-lisp (command buffername init-string)
- "Start Lisp with COMMAND in BUFFERNAME and send INIT-STRING to it.
-Return the new process."
- (let ((proc (slime-inferior-lisp command buffername)))
- (when slime-kill-without-query-p
- (process-kill-without-query proc))
- (when init-string
- (comint-send-string proc init-string)
- proc)))
-
-(defun slime-inferior-lisp (command buffername)
+(defun slime-start-lisp (program program-args buffer)
"Does the same as `inferior-lisp' but less ugly.
Return the created process."
- (let ((args (split-string command))) ; XXX consider: cmucl -eval '(+ 1 2)'
- (with-current-buffer (get-buffer-create buffername)
- (comint-mode)
- (comint-exec (current-buffer) "inferior-lisp" (car args) nil (cdr args))
- (lisp-mode-variables t)
- (get-buffer-process (current-buffer)))))
+ (with-current-buffer (get-buffer-create buffer)
+ (comint-mode)
+ (comint-exec (current-buffer) "inferior-lisp" program nil program-args)
+ (lisp-mode-variables t)
+ (let ((proc (get-buffer-process (current-buffer))))
+ (when slime-kill-without-query-p
+ (process-kill-without-query proc))
+ proc)))
-(defun slime-inferior-connect (process &optional retries symbolic-lisp-name)
+(defun slime-inferior-connect (process args)
"Start a Swank server in the inferior Lisp and connect."
(when (file-regular-p (slime-swank-port-file))
(delete-file (slime-swank-port-file)))
- (slime-start-swank-server process)
- (slime-read-port-and-connect process retries symbolic-lisp-name))
+ (slime-start-swank-server process args)
+ (slime-read-port-and-connect process nil))
-(defun slime-start-swank-server (process)
+(defvar slime-inferior-lisp-args nil
+ "A buffer local variable in the inferior proccess.")
+
+(defun slime-start-swank-server (process args)
"Start a Swank server on the inferior lisp."
- (let* ((encoding (slime-coding-system-cl-name slime-net-coding-system))
- (file (slime-to-lisp-filename (slime-swank-port-file))))
- (comint-send-string process
- (format "(swank:start-server %S :external-format %s)\n"
- file encoding))))
+ (destructuring-bind (&key coding-system init &allow-other-keys) args
+ (with-current-buffer (process-buffer process)
+ (make-local-variable 'slime-inferior-lisp-args)
+ (setq slime-inferior-lisp-args args)
+ (let ((str (funcall init (slime-swank-port-file) coding-system)))
+ (goto-char (process-mark process))
+ (insert-before-markers str)
+ (process-send-string process str)))))
+(defun slime-inferior-lisp-args (process)
+ (with-current-buffer (process-buffer process)
+ slime-inferior-lisp-args))
+
+;; XXX load-server & start-server used to be separated. maybe that was better.
+(defun slime-init-command (port-filename coding-system)
+ "Return a string to initialize Lisp."
+ (let ((loader (if (file-name-absolute-p slime-backend)
+ slime-backend
+ (concat slime-path slime-backend)))
+ (encoding (slime-coding-system-cl-name coding-system)))
+ ;; Return a single form to avoid problems with buffered input.
+ (format "%S\n\n"
+ `(progn
+ (load ,loader :verbose t)
+ (funcall (read-from-string "swank:start-server")
+ ,port-filename
+ :coding-system ,encoding)))))
+
(defun slime-swank-port-file ()
"Filename where the SWANK server writes its TCP port number."
(concat (file-name-as-directory
@@ -1407,11 +1729,10 @@
(t "/tmp/")))
(format "slime.%S" (emacs-pid))))
-(defun slime-read-port-and-connect (inferior-process retries &optional symbolic-lisp-name)
+(defun slime-read-port-and-connect (inferior-process retries)
(lexical-let ((process inferior-process)
(retries retries)
- (attempt 0)
- (lisp-name symbolic-lisp-name))
+ (attempt 0))
(labels
;; A small one-state machine to attempt a connection with
;; timer-based retries.
@@ -1427,16 +1748,18 @@
(cancel-timer slime-connect-retry-timer))
(setq slime-connect-retry-timer nil) ; remove old timer
(cond ((file-exists-p (slime-swank-port-file))
- (let ((port (slime-read-swank-port)))
+ (let ((port (slime-read-swank-port))
+ (args (slime-inferior-lisp-args process)))
(delete-file (slime-swank-port-file))
- (let ((c (slime-connect "127.0.0.1" port nil lisp-name)))
+ (let ((c (slime-connect slime-lisp-host port
+ (plist-get args :coding-system))))
(slime-set-inferior-process c process))))
((and retries (zerop retries))
(message "Failed to connect to Swank."))
(t
(when retries (decf retries))
(setq slime-connect-retry-timer
- (run-with-timer 1 nil #'attempt-connection))))))
+ (run-with-timer 0.2 nil #'attempt-connection))))))
(attempt-connection))))
(defun slime-read-swank-port ()
@@ -1508,6 +1831,9 @@
;;; here. They are defined elsewhere by the event-dispatching
;;; functions in this file and in swank.lisp.
+(defvar slime-lisp-host "127.0.0.1"
+ "The default hostname (or IP address) to connect to.")
+
(defvar slime-net-processes nil
"List of processes (sockets) connected to Lisps.")
@@ -1515,25 +1841,6 @@
"List of functions called when a slime network connection closes.
The functions are called with the process as their argument.")
-(defvar slime-net-coding-system
- (find-if (cond ((featurep 'xemacs)
- (if (fboundp 'find-coding-system)
- #'find-coding-system
- (lambda (x) (eq x 'binary))))
- (t #'coding-system-p))
- '(iso-latin-1-unix iso-8859-1-unix binary))
- "*Coding system used for network connections.
-See also `slime-net-valid-coding-systems'.")
-
-(defvar slime-net-valid-coding-systems
- '((iso-latin-1-unix nil :iso-latin-1-unix)
- (iso-8859-1-unix nil :iso-latin-1-unix)
- (binary nil :iso-latin-1-unix)
- (utf-8-unix t :utf-8-unix)
- (emacs-mule-unix t :emacs-mule-unix))
- "A list of valid coding systems.
-Each element is of the form: (NAME MULTIBYTEP CL-NAME)")
-
(defun slime-secret ()
"Finds the magic secret from the user's home directory.
Returns nil if the file doesn't exist or is empty; otherwise the first
@@ -1546,7 +1853,7 @@
(file-error nil)))
;;; Interface
-(defun slime-net-connect (host port)
+(defun slime-net-connect (host port coding-system)
"Establish a connection with a CL."
(let* ((inhibit-quit nil)
(proc (open-network-stream "SLIME Lisp" nil host port))
@@ -1558,9 +1865,8 @@
(when slime-kill-without-query-p
(process-kill-without-query proc))
(when (fboundp 'set-process-coding-system)
- (set-process-coding-system proc
- slime-net-coding-system
- slime-net-coding-system))
+ (slime-check-coding-system coding-system)
+ (set-process-coding-system proc coding-system coding-system))
(when-let (secret (slime-secret))
(slime-net-send secret proc))
proc))
@@ -1569,25 +1875,55 @@
"Make a buffer suitable for a network process."
(let ((buffer (generate-new-buffer name)))
(with-current-buffer buffer
- (when (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte
- (slime-coding-system-mulibyte-p slime-net-coding-system)))
(buffer-disable-undo))
buffer))
-(defun slime-find-coding-system (&optional coding-system)
- (let* ((coding-system (or coding-system slime-net-coding-system))
- (props (assq coding-system slime-net-valid-coding-systems)))
- (check-coding-system coding-system)
+;;;;; Coding system madness
+
+(defvar slime-net-valid-coding-systems
+ '((iso-latin-1-unix nil "iso-latin-1-unix")
+ (iso-8859-1-unix nil "iso-latin-1-unix")
+ (binary nil "iso-latin-1-unix")
+ (utf-8-unix t "utf-8-unix")
+ (emacs-mule-unix t "emacs-mule-unix")
+ (euc-jp-unix t "euc-jp-unix"))
+ "A list of valid coding systems.
+Each element is of the form: (NAME MULTIBYTEP CL-NAME)")
+
+(defun slime-find-coding-system (name)
+ "Return the coding system for the symbol NAME.
+The result is either an element in `slime-net-valid-coding-systems'
+of nil."
+ (let* ((probe (assq name slime-net-valid-coding-systems)))
+ (if (and probe (if (fboundp 'check-coding-system)
+ (ignore-errors (check-coding-system (car probe)))
+ (eq (car probe) 'binary)))
+ probe)))
+
+(defvar slime-net-coding-system
+ (find-if 'slime-find-coding-system
+ '(iso-latin-1-unix iso-8859-1-unix binary))
+ "*Coding system used for network connections.
+See also `slime-net-valid-coding-systems'.")
+
+(defun slime-check-coding-system (coding-system)
+ "Signal an error if CODING-SYSTEM isn't a valid coding system."
+ (interactive)
+ (let ((props (slime-find-coding-system coding-system)))
(unless props
(error "Invalid slime-net-coding-system: %s. %s"
coding-system (mapcar #'car slime-net-valid-coding-systems)))
- props))
-
-(defun slime-check-coding-system (&optional coding-system)
- (interactive)
- (slime-find-coding-system coding-system))
+ (when (and (second props) (boundp 'default-enable-multibyte-characters))
+ (assert default-enable-multibyte-characters))
+ t))
+(defcustom slime-repl-history-file-coding-system
+ (cond ((slime-find-coding-system 'utf-8-unix) 'utf-8-unix)
+ (t slime-net-coding-system))
+ "*The coding system for the history file."
+ :type 'symbol
+ :group 'slime-repl)
+
(defun slime-coding-system-mulibyte-p (coding-system)
(second (slime-find-coding-system coding-system)))
@@ -1620,12 +1956,18 @@
(and (not (multibyte-string-p string))
(not (slime-coding-system-mulibyte-p coding-system))))))
-(defun slime-net-close (process)
+(defun slime-net-close (process &optional debug)
(setq slime-net-processes (remove process slime-net-processes))
(when (eq process slime-default-connection)
(setq slime-default-connection nil))
- (run-hook-with-args 'slime-net-process-close-hooks process)
- (ignore-errors (kill-buffer (process-buffer process))))
+ (cond (debug
+ (set-process-sentinel process 'ignore)
+ (set-process-filter process 'ignore)
+ (delete-process process))
+ (t
+ (run-hook-with-args 'slime-net-process-close-hooks process)
+ ;; killing the buffer also closes the socket
+ (kill-buffer (process-buffer process)))))
(defun slime-net-sentinel (process message)
(message "Lisp connection closed unexpectedly: %s" message)
@@ -1636,41 +1978,36 @@
;;; complete messages and hands them off to the event dispatcher.
(defun slime-net-filter (process string)
- "Accept output from the socket and input all complete messages."
+ "Accept output from the socket and process all complete messages."
(with-current-buffer (process-buffer process)
- (save-excursion
- (goto-char (point-max))
- (insert string))
- (slime-process-available-input)))
+ (goto-char (point-max))
+ (insert string))
+ (slime-process-available-input process))
-(defun slime-run-when-idle (function)
+(defun slime-run-when-idle (function &rest args)
"Call FUNCTION as soon as Emacs is idle."
- (cond ((featurep 'xemacs)
- (run-at-time itimer-short-interval nil
- (lambda (f) (funcall f)) function))
- (t (run-at-time 0 nil function))))
+ (apply #'run-at-time
+ (if (featurep 'xemacs) itimer-short-interval 0)
+ nil function args))
-(defun slime-process-available-input ()
+(defun slime-process-available-input (process)
"Process all complete messages that have arrived from Lisp."
- (unwind-protect
- (dolist (proc slime-net-processes)
- (with-current-buffer (process-buffer proc)
- (while (slime-net-have-input-p)
- (let ((event (condition-case error
- (slime-net-read)
- (error
- (message "net-read error: %S" error)
- (ding)
- (sleep-for 2)
- (ignore-errors (slime-net-close proc))
- (error "PANIC!")))))
- (save-current-buffer
- (slime-log-event event)
- (slime-dispatch-event event proc))))))
- (dolist (p slime-net-processes)
- (with-current-buffer (process-buffer p)
- (when (slime-net-have-input-p)
- (slime-run-when-idle 'slime-process-available-input))))))
+ (with-current-buffer (process-buffer process)
+ (while (slime-net-have-input-p)
+ (let ((event (condition-case error
+ (slime-net-read)
+ (error
+ (slime-net-close process t)
+ (error "net-read error: %S" error)))))
+ (slime-log-event event)
+ (let ((ok nil))
+ (unwind-protect
+ (save-current-buffer
+ (slime-dispatch-event event process)
+ (setq ok t))
+ (unless ok
+ (slime-run-when-idle
+ 'slime-process-available-input process))))))))
(defun slime-net-have-input-p ()
"Return true if a complete message is available."
@@ -1684,13 +2021,14 @@
(let* ((length (slime-net-decode-length))
(start (+ 6 (point)))
(end (+ start length)))
- (let ((string (buffer-substring start end)))
+ (assert (plusp length))
+ (let ((string (buffer-substring-no-properties start end)))
(prog1 (read string)
(delete-region (point-min) end)))))
(defun slime-net-decode-length ()
"Read a 24-bit hex-encoded integer from buffer."
- (string-to-number (buffer-substring (point) (+ (point) 6)) 16))
+ (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) 16))
(defun slime-net-encode-length (n)
"Encode an integer into a 24-bit hex string."
@@ -1766,11 +2104,17 @@
Used for all Lisp communication, except when overridden by
`slime-dispatching-connection' or `slime-buffer-connection'.")
+(defun slime-current-connection ()
+ "Return the connection to use for Lisp interaction.
+Return nil if there's no connection."
+ (or slime-dispatching-connection
+ slime-buffer-connection
+ slime-default-connection))
+
(defun slime-connection ()
- "Return the connection to use for Lisp interaction."
- (let ((conn (or slime-dispatching-connection
- slime-buffer-connection
- slime-default-connection)))
+ "Return the connection to use for Lisp interaction.
+Signal an error if there's no connection."
+ (let ((conn (slime-current-connection)))
(cond ((and (not conn) slime-net-processes)
(error "No default connection selected."))
((not conn)
@@ -1871,15 +2215,12 @@
(slime-def-connection-var slime-lisp-implementation-version nil
"The implementation type of the Lisp process.")
-(slime-def-connection-var slime-lisp-implementation-type-name nil
- "The short name for the implementation type of the Lisp process.")
+(slime-def-connection-var slime-lisp-implementation-name nil
+ "The short name for the Lisp implementation.")
(slime-def-connection-var slime-connection-name nil
"The short name for connection.")
-(slime-def-connection-var slime-symbolic-lisp-name nil
- "The symbolic name passed to slime when starting connection.")
-
(slime-def-connection-var slime-inferior-process nil
"The inferior process for the connection if any.")
@@ -1895,14 +2236,14 @@
"The number of SLIME connections made. For generating serial numbers.")
;;; Interface
-(defun slime-setup-connection (process symbolic-lisp-name)
+(defun slime-setup-connection (process)
"Make a connection out of PROCESS."
(let ((slime-dispatching-connection process))
- (slime-init-connection-state process symbolic-lisp-name)
+ (slime-init-connection-state process)
(slime-select-connection process)
process))
-(defun slime-init-connection-state (proc symbolic-lisp-name)
+(defun slime-init-connection-state (proc)
"Initialize connection state in the process-buffer of PROC."
;; To make life simpler for the user: if this is the only open
;; connection then reset the connection counter.
@@ -1911,31 +2252,47 @@
(slime-with-connection-buffer ()
(setq slime-buffer-connection proc))
(setf (slime-connection-number proc) (incf slime-connection-counter))
- (setf (slime-symbolic-lisp-name proc)
- (slime-generate-symbolic-lisp-name symbolic-lisp-name))
- ;; We do our initialization asynchronously. The current function may
- ;; be called from a timer, and if we setup the REPL from a timer
- ;; then it mysteriously uses the wrong keymap for the first command.
+ ;; We do the rest of our initialization asynchronously. The current
+ ;; function may be called from a timer, and if we setup the REPL
+ ;; from a timer then it mysteriously uses the wrong keymap for the
+ ;; first command.
(slime-eval-async '(swank:connection-info)
- (lambda (info)
- (slime-set-connection-info proc info))))
+ (lexical-let ((proc proc))
+ (lambda (info)
+ (slime-set-connection-info proc info)))))
(defun slime-set-connection-info (connection info)
"Initialize CONNECTION with INFO received from Lisp."
- (destructuring-bind (pid type name features style version host) info
- (setf (slime-pid) pid
- (slime-lisp-implementation-type) type
- (slime-lisp-implementation-type-name) name
- (slime-connection-name) (slime-generate-connection-name name)
- (slime-lisp-features) features
- (slime-communication-style) style
- (slime-lisp-implementation-version) version
- (slime-machine-instance) host))
- (setq slime-state-name "") ; FIXME
- (slime-hide-inferior-lisp-buffer)
- (slime-init-output-buffer connection)
- (run-hooks 'slime-connected-hook)
- (message "Connected. %s" (slime-random-words-of-encouragement)))
+ (let ((slime-dispatching-connection connection))
+ (destructuring-bind (&key pid style lisp-implementation machine
+ features package version &allow-other-keys) info
+ (or (equal version slime-protocol-version)
+ (yes-or-no-p "Protocol version mismatch. Continue anyway? ")
+ (slime-net-close connection)
+ (top-level))
+ (setf (slime-pid) pid
+ (slime-communication-style) style
+ (slime-lisp-features) features)
+ (destructuring-bind (&key name prompt) package
+ (setf (slime-lisp-package) name
+ (slime-lisp-package-prompt-string) prompt))
+ (destructuring-bind (&key type name version) lisp-implementation
+ (setf (slime-lisp-implementation-type) type
+ (slime-lisp-implementation-version) version
+ (slime-lisp-implementation-name) name
+ (slime-connection-name) (slime-generate-connection-name name)))
+ (destructuring-bind (&key instance type version) machine
+ (setf (slime-machine-instance) instance)))
+ (setq slime-state-name "") ; FIXME
+ (when-let (p (slime-inferior-process))
+ (when-let (name (plist-get (slime-inferior-lisp-args p) ':name))
+ (unless (string= (slime-lisp-implementation-name) name)
+ (setf (slime-connection-name)
+ (slime-generate-connection-name (symbol-name name))))))
+ (slime-hide-inferior-lisp-buffer)
+ (slime-init-output-buffer connection)
+ (run-hooks 'slime-connected-hook)
+ (message "Connected. %s" (slime-random-words-of-encouragement))))
(defun slime-generate-connection-name (lisp-name)
(loop for i from 1
@@ -1944,15 +2301,6 @@
:key #'slime-connection-name :test #'equal)
finally (return name)))
-(defun slime-generate-symbolic-lisp-name (lisp-name)
- (if lisp-name
- (loop for i from 1
- for name = lisp-name then (format "%s<%d>" lisp-name i)
- while (find name slime-net-processes
- :key #'slime-symbolic-lisp-name :test #'equal)
- finally (return name))))
-
-
(defun slime-connection-close-hook (process)
(when (eq process slime-default-connection)
(when slime-net-processes
@@ -2023,7 +2371,12 @@
"*If true, don't send background requests if Lisp is already busy.")
(defun slime-background-activities-enabled-p ()
- (and (slime-connected-p)
+ (and (or slime-mode
+ (eq major-mode 'sldb-mode)
+ (eq major-mode 'slime-repl-mode))
+ (let ((con (slime-current-connection)))
+ (and con
+ (eq (process-status con) 'open)))
(or (not (slime-busy-p))
(not slime-inhibit-pipelining))))
@@ -2078,8 +2431,8 @@
This is set only in buffers bound to specific packages."))
;;; `slime-rex' is the RPC primitive which is used to implement both
-;;; `slime-eval' and `slime-eval-async'. You can use it directly you
-;;; need to but the others are usually more convenient.
+;;; `slime-eval' and `slime-eval-async'. You can use it directly if
+;;; you need to, but the others are usually more convenient.
(defmacro* slime-rex ((&rest saved-vars)
(sexp &optional
@@ -2098,10 +2451,11 @@
PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package.
The default value is (slime-current-package).
-CLAUSES is a list of patterns with same syntax as `destructure-case'.
-The result of the evaluation is dispatched on CLAUSES. The result is
-either a sexp of the form (:ok VALUE) or (:abort). CLAUSES is
-executed asynchronously.
+CLAUSES is a list of patterns with same syntax as
+`destructure-case'. The result of the evaluation of SEXP is
+dispatched on CLAUSES. The result is either a sexp of the
+form (:ok VALUE) or (:abort REASON). CLAUSES is executed
+asynchronously.
Note: don't use backquote syntax for SEXP, because Emacs20 cannot
deal with that."
@@ -2125,32 +2479,42 @@
search for and read an `in-package' form.
The REPL buffer is a special case: it's package is `slime-lisp-package'."
- (or (and (eq major-mode 'slime-repl-mode) (slime-lisp-package))
- slime-buffer-package
- (save-restriction
- (widen)
- (slime-find-buffer-package))))
+ (cond ((eq major-mode 'slime-repl-mode)
+ (slime-lisp-package))
+ (slime-buffer-package)
+ (t (save-restriction
+ (widen)
+ (slime-find-buffer-package)))))
-(defvar slime-find-buffer-package-function nil
- "Function to use instead of `slime-find-buffer-package'.
-The result should be a string. The string will be READ at the Lisp
-side.")
+(defvar slime-find-buffer-package-function 'slime-search-buffer-package
+ "*Function to use for `slime-find-buffer-package'.
+The result should be the package-name (a string)
+or nil if nothing suitable can be found.")
(defun slime-find-buffer-package ()
"Figure out which Lisp package the current buffer is associated with."
- (if slime-find-buffer-package-function
- (funcall slime-find-buffer-package-function)
+ (funcall slime-find-buffer-package-function))
+
+;; When modifing this code consider cases like:
+;; (in-package #.*foo*)
+;; (in-package #:cl)
+;; (in-package :cl)
+;; (in-package "CL")
+;; (in-package |CL|)
+;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp)
+(defun slime-search-buffer-package ()
+ (let ((case-fold-search t)
+ (regexp (concat "^(\\(cl:\\|common-lisp:\\)?in-package\\>[ \n\t\r']*"
+ "\\([^)]+\\)[ \n\t]*)")))
(save-excursion
- (when (let ((case-fold-search t)
- (regexp "^(\\(cl:\\|common-lisp:\\)?in-package\\>"))
- (or (re-search-backward regexp nil t)
- (re-search-forward regexp nil t)))
- (goto-char (match-end 0))
- (skip-chars-forward " \n\t\f\r#'")
- (let ((pkg (ignore-errors (read (current-buffer)))))
- (if pkg (format "%S" pkg)))))))
+ (when (or (re-search-backward regexp nil t)
+ (re-search-forward regexp nil t))
+ (let ((string (match-string-no-properties 2)))
+ (cond ((string-match "^\"" string) (ignore-errors (read string)))
+ ((string-match "^#?:" string) (substring string (match-end 0)))
+ (t string)))))))
-;;; Synchronous requests is implemented in terms of asynchronous
+;;; Synchronous requests are implemented in terms of asynchronous
;;; ones. We make an asynchronous request with a continuation function
;;; that `throw's its result up to a `catch' and then enter a loop of
;;; handling I/O until that happens.
@@ -2161,7 +2525,8 @@
(defun slime-eval (sexp &optional package)
"Evaluate EXPR on the superior Lisp and return the result."
(when (null package) (setq package (slime-current-package)))
- (let* ((tag (gensym "slime-result-"))
+ (let* ((tag (gensym (format "slime-result-%d-"
+ (1+ (slime-continuation-counter)))))
(slime-stack-eval-tags (cons tag slime-stack-eval-tags)))
(apply
#'funcall
@@ -2173,11 +2538,15 @@
(error "tag = %S eval-tags = %S sexp = %S"
tag slime-stack-eval-tags sexp))
(throw tag (list #'identity value)))
- ((:abort)
- (throw tag (list #'error "Synchronous Lisp Evaluation aborted."))))
+ ((:abort &optional reason)
+ (throw tag (list #'error (or reason "Synchronous Lisp Evaluation aborted.")))))
(let ((debug-on-quit t)
- (inhibit-quit nil))
- (while t (accept-process-output nil 0 10000)))))))
+ (inhibit-quit nil)
+ (conn (slime-connection)))
+ (while t
+ (unless (eq (process-status conn) 'open)
+ (error "Lisp connection closed unexpectedly"))
+ (slime-accept-process-output nil 0.01)))))))
(defun slime-eval-async (sexp &optional cont package)
"Evaluate EXPR on the superior Lisp and call CONT with the result."
@@ -2185,8 +2554,8 @@
(sexp (or package (slime-current-package)))
((:ok result)
(when cont (funcall cont result)))
- ((:abort)
- (message "Evaluation aborted."))))
+ ((:abort &optional reason)
+ (message (or reason "Evaluation aborted.")))))
;;; These functions can be handy too:
@@ -2219,7 +2588,7 @@
(when (slime-rex-continuations)
(let ((tag (caar (slime-rex-continuations))))
(while (find tag (slime-rex-continuations) :key #'car)
- (accept-process-output nil 0 100000)))))
+ (slime-accept-process-output nil 0.1)))))
(defun slime-ping ()
"Check that communication works."
@@ -2243,17 +2612,15 @@
(slime-def-connection-var slime-continuation-counter 0
"Continuation serial number counter.")
-(defvar slime-current-output-id nil
- "The id of the current repl output.
-
-This variable is rebound by the :RETURN event handler and used by
-slime-repl-insert-prompt.")
-
(defun slime-dispatch-event (event &optional process)
(let ((slime-dispatching-connection (or process (slime-connection))))
(destructure-case event
- ((:read-output output)
- (slime-output-string output))
+ ((:write-string output)
+ (slime-write-string output))
+ ((:presentation-start id)
+ (slime-mark-presentation-start id))
+ ((:presentation-end id)
+ (slime-mark-presentation-end id))
;;
((:emacs-rex form package thread continuation)
(slime-set-state "|eval...")
@@ -2264,13 +2631,11 @@
(slime-send `(:emacs-rex ,form ,package ,thread ,id))))
((:return value id)
(let ((rec (assq id (slime-rex-continuations))))
- (cond (rec (setf (slime-rex-continuations )
+ (cond (rec (setf (slime-rex-continuations)
(remove rec (slime-rex-continuations)))
(when (null (slime-rex-continuations))
(slime-set-state ""))
- (let ((slime-current-output-id id)) ;; this is not very
- ;; elegant but it avoids changing the protocol
- (funcall (cdr rec) value)))
+ (funcall (cdr rec) value))
(t
(error "Unexpected reply: %S %S" id value)))))
((:debug-activate thread level)
@@ -2279,18 +2644,16 @@
((:debug thread level condition restarts frames conts)
(assert thread)
(sldb-setup thread level condition restarts frames conts))
- ((:debug-return thread level &optional stepping)
+ ((:debug-return thread level stepping)
(assert thread)
(sldb-exit thread level stepping))
((:emacs-interrupt thread)
- (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint))
- (t (slime-send `(:emacs-interrupt ,thread)))))
+ (slime-send `(:emacs-interrupt ,thread)))
((:read-string thread tag)
(assert thread)
(slime-repl-read-string thread tag))
- ((:evaluate-in-emacs string thread tag)
- (assert thread)
- (evaluate-in-emacs (car (read-from-string string)) thread tag))
+ ((:y-or-n-p thread tag question)
+ (slime-y-or-n-p thread tag question))
((:read-aborted thread tag)
(assert thread)
(slime-repl-abort-read thread tag))
@@ -2307,13 +2670,16 @@
((:open-dedicated-output-stream port)
(slime-open-stream-to-lisp port))
((:eval-no-wait fun args)
+ (slime-check-eval-in-emacs-enabled)
(apply (intern fun) args))
- ((:eval thread tag fun args)
- (slime-eval-for-lisp thread tag (intern fun) args))
+ ((:eval thread tag form-string)
+ (slime-eval-for-lisp thread tag form-string))
((:emacs-return thread tag value)
(slime-send `(:emacs-return ,thread ,tag ,value)))
((:ed what)
(slime-ed what))
+ ((:background-message message)
+ (slime-background-message "%s" message))
((:debug-condition thread message)
(assert thread)
(message "%s" message)))))
@@ -2328,11 +2694,9 @@
(setf (slime-rex-continuations) '())
(mapc #'kill-buffer (sldb-buffers)))
-(defconst +slime-sigint+ 2)
-
(defun slime-send-sigint ()
(interactive)
- (signal-process (slime-pid) +slime-sigint+))
+ (signal-process (slime-pid) 'SIGINT))
;;;;; Event logging to *slime-events*
;;;
@@ -2387,6 +2751,9 @@
;;;; Stream output
+(slime-def-connection-var slime-connection-output-buffer nil
+ "The buffer for the REPL. May be nil or a dead buffer.")
+
(defcustom slime-header-line-p t
"If non-nil, display a header line in Slime buffers."
:type 'boolean
@@ -2415,14 +2782,18 @@
(defun slime-output-buffer (&optional noprompt)
"Return the output buffer, create it if necessary."
- (or (slime-repl-buffer)
- (let ((connection (slime-connection)))
- (with-current-buffer (slime-repl-buffer t)
- (slime-repl-mode)
- (setq slime-buffer-connection connection)
- (slime-reset-repl-markers)
- (unless noprompt (slime-repl-insert-prompt "" 0))
- (current-buffer)))))
+ (let ((buffer (slime-connection-output-buffer)))
+ (or (if (buffer-live-p buffer) buffer)
+ (setf (slime-connection-output-buffer)
+ (let ((connection (slime-connection)))
+ (with-current-buffer (slime-repl-buffer t connection)
+ (unless (eq major-mode 'slime-repl-mode)
+ (slime-repl-mode))
+ (setq slime-buffer-connection connection)
+ (slime-reset-repl-markers)
+ (unless noprompt
+ (slime-repl-insert-prompt '(:suppress-output) 0))
+ (current-buffer)))))))
(defun slime-repl-update-banner ()
(let* ((banner (format "%s Port: %s Pid: %s"
@@ -2443,26 +2814,14 @@
(animate-string (format "; SLIME %s" (or (slime-changelog-date)
"- ChangeLog file not found"))
0 0))
- (slime-repl-insert-prompt (if use-header-p "" (concat "; " banner)))))
+ (slime-repl-insert-prompt (cond (use-header-p `(:suppress-output))
+ (t `(:values (,(concat "; " banner))))))))
-(defun slime-changelog-date ()
- "Return the datestring of the latest entry in the ChangeLog file.
-Return nil if the ChangeLog file cannot be found."
- (let ((changelog (concat slime-path "ChangeLog")))
- (if (file-exists-p changelog)
- (with-temp-buffer
- (insert-file-contents changelog nil 0 100)
- (goto-char (point-min))
- (symbol-name (read (current-buffer))))
- nil)))
-
(defun slime-init-output-buffer (connection)
(with-current-buffer (slime-output-buffer t)
- (setq slime-buffer-connection connection)
- ;; set the directory stack
- (setq slime-repl-directory-stack
- (list (expand-file-name default-directory)))
- (setq slime-repl-package-stack (list (slime-lisp-package)))
+ (setq slime-buffer-connection connection
+ slime-repl-directory-stack '()
+ slime-repl-package-stack '())
(slime-repl-update-banner)))
(defvar slime-show-last-output-function
@@ -2482,14 +2841,10 @@
(display-buffer (current-buffer)))
(when (eobp)
(slime-repl-show-maximum-output t)))
-
-(defun slime-flush-output ()
- (while (accept-process-output nil 0 20)))
(defun slime-show-last-output ()
"Show the output from the last Lisp evaluation."
(with-current-buffer (slime-output-buffer)
- (slime-flush-output)
(let ((start slime-output-start)
(end slime-output-end))
(funcall slime-show-last-output-function start end))))
@@ -2526,27 +2881,184 @@
(> (- slime-output-end slime-output-start) 1000)))))
(defun slime-output-filter (process string)
- (when (and (slime-connected-p)
- (plusp (length string)))
- (with-current-buffer (process-buffer process)
- (slime-output-string string))))
+ (with-current-buffer (process-buffer process)
+ (when (and (plusp (length string))
+ (eq (process-status slime-buffer-connection) 'open))
+ (slime-write-string string))))
+;; FIXME: This conditional is not right - just used because the code
+;; here does not work in XEmacs.
+(when slime-repl-enable-presentations
+ (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)
+ (setf (gethash id slime-presentation-start-to-point)
+ (with-current-buffer (slime-output-buffer)
+ (marker-position (symbol-value 'slime-output-end)))))
+
+(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)
+ (let ((start (gethash id slime-presentation-start-to-point)))
+ (remhash id slime-presentation-start-to-point)
+ (when start
+ (with-current-buffer (slime-output-buffer)
+ (slime-add-presentation-properties start (symbol-value 'slime-output-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))))
+
+(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))))
+
+(defun slime-ensure-presentation-overlay (start end presentation)
+ (unless (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)
+ (cond ((not slime-repl-enable-presentations)
+ (insert string))
+ (t
+ (let ((start (point)))
+ (insert string)
+ (slime-add-presentation-properties start (point) output-id t)))))
+
(defun slime-open-stream-to-lisp (port)
(let ((stream (open-network-stream "*lisp-output-stream*"
(slime-with-connection-buffer ()
(current-buffer))
- "127.0.0.1" port)))
+ slime-lisp-host port)))
(when slime-kill-without-query-p
(process-kill-without-query stream))
(set-process-filter stream 'slime-output-filter)
- (set-process-coding-system stream
- slime-net-coding-system
- slime-net-coding-system)
+ (when slime-repl-enable-presentations
+ (require 'bridge)
+ (defun bridge-insert (process output)
+ (slime-output-filter process (or output "")))
+ (install-bridge)
+ (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)))
+ (let ((pcs (process-coding-system (slime-current-connection))))
+ (set-process-coding-system stream (car pcs) (cdr pcs)))
(when-let (secret (slime-secret))
(slime-net-send secret stream))
stream))
-(defun slime-output-string (string)
+(defun slime-io-speed-test (&optional profile)
+ "A simple minded benchmark for stream performance.
+If a prefix argument is given, instrument the slime package for
+profiling before running the benchmark."
+ (interactive "P")
+ (eval-and-compile
+ (require 'elp))
+ (elp-reset-all)
+ (elp-restore-all)
+ (load "slime.el")
+ ;;(byte-compile-file "slime-net.el" t)
+ ;;(setq slime-log-events nil)
+ (setq slime-enable-evaluate-in-emacs t)
+ ;;(setq slime-repl-enable-presentations nil)
+ (when profile
+ (elp-instrument-package "slime-"))
+ (kill-buffer (slime-output-buffer))
+ ;;(display-buffer (slime-output-buffer))
+ (delete-other-windows)
+ (sit-for 0)
+ (slime-repl-send-string "(swank:io-speed-test 5000 1)")
+ (let ((proc (slime-inferior-process)))
+ (when proc
+ (switch-to-buffer (process-buffer proc))
+ (goto-char (point-max)))))
+
+(defun slime-write-string (string)
(with-current-buffer (slime-output-buffer)
(slime-with-output-end-mark
(slime-propertize-region '(face slime-repl-output-face)
@@ -2634,7 +3146,7 @@
(defvar slime-repl-input-history '()
"History list of strings read from the REPL buffer.")
- (defvar slime-repl-input-history-position 0
+ (defvar slime-repl-input-history-position -1
"Newer items have smaller indices.")
(defvar slime-repl-prompt-start-mark)
@@ -2651,9 +3163,7 @@
(defun slime-repl-buffer (&optional create connection)
"Get the REPL buffer for the current connection; optionally create."
(funcall (if create #'get-buffer-create #'get-buffer)
- (format "*slime-repl %s*"
- (or (slime-symbolic-lisp-name connection)
- (slime-connection-name connection)))))
+ (format "*slime-repl %s*" (slime-connection-name connection))))
(defun slime-repl-mode ()
"Major mode for interacting with a superior Lisp.
@@ -2670,94 +3180,326 @@
(setq slime-current-thread :repl-thread)
(set (make-local-variable 'scroll-conservatively) 20)
(set (make-local-variable 'scroll-margin) 0)
+ (slime-repl-safe-load-history)
+ (add-local-hook 'kill-buffer-hook 'slime-repl-safe-save-merged-history)
+ (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories)
(slime-setup-command-hooks)
+ (when slime-use-autodoc-mode
+ (slime-autodoc-mode 1))
+ (when slime-repl-enable-presentations
+ ;; Respect the syntax text properties of presentations.
+ (set (make-local-variable 'parse-sexp-lookup-properties) t))
(run-hooks 'slime-repl-mode-hook))
-;; alanr
-(defun slime-presentation-command-hook ()
- (let* ((props-here (text-properties-at (point)))
- (props-before (and (not (= (point) (point-min))) (text-properties-at (1- (point)))))
- (inside (and (getf props-here 'slime-repl-old-output)))
- (at-beginning (and inside (not (getf props-before 'slime-repl-old-output))))
- (at-end (and (or (= (point) (point-max)) (not (getf props-here 'slime-repl-old-output)))
- (getf props-before 'slime-repl-old-output)))
- (start (cond (at-beginning (point))
- (inside (previous-single-property-change (point) 'slime-repl-old-output))
- (at-end (previous-single-property-change (1- (point)) 'slime-repl-old-output))))
- (end (cond (at-beginning (or (next-single-property-change (point) 'slime-repl-old-output) (point-max)))
- (inside (or (next-single-property-change (point) 'slime-repl-old-output) (point-max)))
- (at-end (point)))))
- ; (setq message (format "%s %s %s %s %s" at-beginning inside at-end start end))
- (when (and (or inside at-end) start end (> end start))
- (let ((kind (get this-command 'action-type)))
- ; (message (format "%s %s %s %s" at-beginning inside at-end kind))
- (cond ((and (eq kind 'inserts) inside (not at-beginning))
- (setq this-command 'ignore-event))
- ((and (eq kind 'deletes-forward) inside (not at-end))
- (kill-region start end)
- (setq this-command 'ignore-event))
- ((and (eq kind 'deletes-backward) (or inside at-end) (not at-beginning))
- (kill-region start end)
- (setq this-command 'ignore-event))))))
- )
+(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-presentation-post-command-hook ()
- (when (null pre-command-hook)
- (message "Lost the pre-command-hook. Putting it back!") ; can't seem to prevent this losing, even when trying to catch error
- (add-hook 'pre-command-hook 'slime-pre-command-hook)
- (add-hook 'pre-command-hook 'slime-presentation-command-hook)))
+(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-copy-presentation-at-point (event)
+(defun slime-presentation-start-p (tag)
+ (memq tag '(:start :start-and-end)))
+
+(defun slime-presentation-stop-p (tag)
+ (memq tag '(:end :start-and-end)))
+
+(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)))
+ (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)))
+
+(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))))
+
+(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 presentation
+ (values presentation start end whole-p)
+ (slime-presentation-around-point (1- point) object)))))
+
+(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'."
+ (flet ((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(a)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-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)
+ (if (with-current-buffer buffer
+ (eq major-mode 'slime-repl-mode))
+ (slime-copy-presentation-at-mouse event)
+ (slime-inspect-presentation-at-mouse event))))
+
+(defun slime-inspect-presentation-at-mouse (event)
(interactive "e")
- (let* ((point (posn-point (event-end event)))
- (what (get-text-property point 'slime-repl-old-output))
- (start (previous-single-property-change point 'slime-repl-old-output))
- (end (or (next-single-property-change point 'slime-repl-old-output) (point-max))))
- (when (not (string-match "\\s-" (buffer-substring (1- (point)) (point))))
- (insert " "))
- (slime-propertize-region '(face slime-repl-inputed-output-face)
- (insert (buffer-substring start end)))
- (when (and (not (eolp)) (not (looking-at "\\s-")))
- (insert " "))))
+ (multiple-value-bind (presentation start end buffer)
+ (slime-presentation-around-click event)
+ (let ((reset-p
+ (with-current-buffer buffer
+ (not (eq major-mode 'slime-inspector-mode)))))
+ (slime-inspect (slime-presentation-expression presentation)
+ (not reset-p)))))
-(put 'self-insert-command 'action-type 'inserts)
-(put 'self-insert-command-1 'action-type 'inserts)
-(put 'yank 'action-type 'inserts)
-(put 'kill-word 'action-type 'deletes-forward)
-(put 'delete-char 'action-type 'deletes-forward)
-(put 'kill-sexp 'action-type 'deletes-forward)
-(put 'backward-kill-sexp 'action-type 'deletes-backward)
-(put 'backward-delete-char 'action-type 'deletes-backward)
-(put 'backward-kill-word 'action-type 'deletes-backward)
-(put 'backward-delete-char-untabify 'action-type 'deletes-backward)
-(put 'slime-repl-newline-and-indent 'action-type 'inserts)
+(defun slime-copy-presentation-at-mouse (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))))
+ (unless (eql major-mode 'slime-repl-mode)
+ (slime-switch-to-output-buffer))
+ (flet ((do-insertion ()
+ (when (not (string-match "\\s-"
+ (buffer-substring (1- (point)) (point))))
+ (insert " "))
+ (insert presentation-text)
+ (when (and (not (eolp)) (not (looking-at "\\s-")))
+ (insert " "))))
+ (if (>= (point) slime-repl-prompt-start-mark)
+ (do-insertion)
+ (save-excursion
+ (goto-char (point-max))
+ (do-insertion)))))))
+(defun slime-describe-presentation-at-mouse (event)
+ (interactive "@e")
+ (multiple-value-bind (presentation) (slime-presentation-around-click event)
+ (slime-eval-describe
+ `(swank::describe-to-string
+ (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-eval-describe
+ `(swank::swank-pprint
+ (cl:list
+ (swank::lookup-presented-object ',(slime-presentation-id presentation)))))))
+
+(defvar slime-presentation-map (make-sparse-keymap))
+
+(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 from to choice-to-lambda)
+ "Return a menu for `presentation' at `from'--`to' in the current
+buffer, suitable for `x-popup-menu'."
+ (let* ((what (slime-presentation-id presentation))
+ (choices (slime-eval
+ `(swank::menu-choices-for-presentation-id ',what))))
+ (flet ((savel (f) ;; IMPORTANT - xemacs can't handle lambdas in x-popup-menu. So give them a name
+ (let ((sym (gensym)))
+ (setf (gethash sym choice-to-lambda) f)
+ sym)))
+ (etypecase choices
+ (list
+ `(,(if (featurep 'xemacs) " " "")
+ (""
+ ("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 input" . ,(savel 'slime-copy-presentation-at-mouse))
+ ,@(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
+ (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)))
+ (choice-to-lambda (make-hash-table)))
+ (with-current-buffer (window-buffer window)
+ (multiple-value-bind (presentation from to)
+ (slime-presentation-around-point point)
+ (unless presentation
+ (error "No presentation at event position"))
+ (let ((menu (slime-menu-choices-for-presentation
+ presentation from to choice-to-lambda)))
+ (let ((choice (x-popup-menu event menu)))
+ (when choice
+ (call-interactively (gethash choice choice-to-lambda)))))))))
+
(defun slime-repl-insert-prompt (result &optional time)
- "Goto to point max, insert RESULT and the prompt. Set
-slime-output-end to start of the inserted text slime-input-start to
-end end."
- (slime-flush-output)
+ "Goto to point max, insert RESULT and the prompt.
+Set slime-output-end to start of the inserted text slime-input-start
+to end end."
(goto-char (point-max))
(let ((start (point)))
(unless (bolp) (insert "\n"))
- (unless (string= "" result)
- (slime-propertize-region `(face slime-repl-result-face
- slime-repl-old-output ,slime-current-output-id
- mouse-face slime-repl-output-mouseover-face
- keymap (keymap (mouse-2 . slime-copy-presentation-at-point)))
- (insert result))
- (unless (bolp) (insert "\n"))
- (let ((inhibit-read-only t))
- (put-text-property (- (point) 2) (point)
- 'rear-nonsticky
- '(slime-repl-old-output face read-only))))
+ (slime-repl-insert-result result)
(let ((prompt-start (point))
(prompt (format "%s> " (slime-lisp-package-prompt-string))))
(slime-propertize-region
- '(face slime-repl-prompt-face
- read-only t
- intangible t
+ '(face slime-repl-prompt-face read-only t intangible t
slime-repl-prompt t
;; emacs stuff
rear-nonsticky (slime-repl-prompt read-only face intangible)
@@ -2777,6 +3519,26 @@
(current-buffer)))))))
(slime-repl-show-maximum-output))
+(defun slime-repl-insert-result (result)
+ "Insert the result of an evaluation.
+RESULT can be one of:
+ (:values (STRING...))
+ (:present ((STRING . ID)...))
+ (:suppress-output)"
+ (destructure-case result
+ ((:values strings)
+ (cond ((null strings) (insert "; No value\n"))
+ (t (dolist (s strings)
+ (slime-insert-propertized `(face slime-repl-result-face) s)
+ (insert "\n")))))
+ ((:present stuff)
+ (cond ((and stuff slime-repl-enable-presentations)
+ (loop for (s . id) in stuff do
+ (slime-insert-presentation s id)
+ (insert "\n")))
+ (t (slime-repl-insert-result `(:values ,(mapcar #'car stuff))))))
+ ((:suppress-output))))
+
(defun slime-repl-move-output-mark-before-prompt (buffer)
(when (buffer-live-p buffer)
(with-current-buffer buffer
@@ -2799,25 +3561,40 @@
"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."
- (let ((str-props (buffer-substring slime-repl-input-start-mark
- slime-repl-input-end-mark))
- (str-no-props (buffer-substring-no-properties slime-repl-input-start-mark
- slime-repl-input-end-mark)))
- (reify-old-output str-props str-no-props)))
+ (slime-buffer-substring-with-reified-output slime-repl-input-start-mark
+ slime-repl-input-end-mark))
-(defun reify-old-output (str-props str-no-props)
- (let ((pos (slime-property-position 'slime-repl-old-output str-props)))
+(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:get-repl-result #10r%d)" id))
+ (list
+ ;; for frame variables and inspector parts
+ (format "(swank:get-repl-result '%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
- (let ((end-pos (or (next-single-property-change pos 'slime-repl-old-output str-props)
- (length str-props)))
- (id (get-text-property pos 'slime-repl-old-output str-props)))
- (concat (substring str-no-props 0 pos)
- ;; Eval in the reader so that we play nice with quote.
- ;; -luke (19/May/2005)
- "#." (slime-prin1-to-string `(swank:get-repl-result ,id))
- (reify-old-output (substring str-props end-pos)
- (substring str-no-props end-pos)))))))
+ (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-property-position (text-property &optional object)
"Return the first position of TEXT-PROPERTY, or nil."
@@ -2829,7 +3606,8 @@
(when (and (plusp (length string))
(eq ?\n (aref string (1- (length string)))))
(setq string (substring string 0 -1)))
- (unless (equal string (car slime-repl-input-history))
+ (unless (or (= (length string) 0)
+ (equal string (car slime-repl-input-history)))
(push string slime-repl-input-history))
(setq slime-repl-input-history-position -1))
@@ -2842,7 +3620,6 @@
((:abort) (slime-repl-show-abort))))
(defun slime-repl-send-string (string &optional command-string)
- (slime-repl-add-to-input-history (or command-string string))
(cond (slime-repl-read-mode
(slime-repl-return-string string))
(t (slime-repl-eval-string string))))
@@ -2854,8 +3631,10 @@
(insert-before-markers "; Evaluation aborted\n"))
(slime-rex ()
((list 'swank:listener-eval "") nil)
- ((:ok result) (with-current-buffer (slime-output-buffer)
- (slime-repl-insert-prompt ""))))))
+ ((:ok result)
+ ;; A hack to get the prompt
+ (with-current-buffer (slime-output-buffer)
+ (slime-repl-insert-prompt '(:suppress-output)))))))
(defun slime-mark-input-start ()
(set-marker slime-repl-last-input-start-mark
@@ -2869,16 +3648,19 @@
(set-marker slime-output-end position)))
(defun slime-mark-output-end ()
+ ;; Don't put slime-repl-output-face again; it would remove the
+ ;; special presentation face, for instance in the SBCL inspector.
(add-text-properties slime-output-start slime-output-end
- '(face slime-repl-output-face rear-nonsticky (face))))
+ '(;;face slime-repl-output-face
+ rear-nonsticky (face))))
(defun slime-repl-bol ()
"Go to the beginning of line or the prompt."
(interactive)
- (if (and (>= (point) slime-repl-input-start-mark)
- (slime-same-line-p (point) slime-repl-input-start-mark))
- (goto-char slime-repl-input-start-mark)
- (beginning-of-line 1))
+ (cond ((and (>= (point) slime-repl-input-start-mark)
+ (slime-same-line-p (point) slime-repl-input-start-mark))
+ (goto-char slime-repl-input-start-mark))
+ (t (beginning-of-line 1)))
(slime-preserve-zmacs-region))
(defun slime-repl-eol ()
@@ -2957,51 +3739,58 @@
(interactive "P")
(slime-check-connected)
(assert (<= (point) slime-repl-input-end-mark))
- (cond ((and (get-text-property (point) 'slime-repl-old-input)
+ (cond (end-of-input
+ (slime-repl-send-input))
+ (slime-repl-read-mode ; bad style?
+ (slime-repl-send-input t))
+ ((and (get-text-property (point) 'slime-repl-old-input)
(< (point) slime-repl-input-start-mark))
(slime-repl-grab-old-input end-of-input)
- (unless (pos-visible-in-window-p slime-repl-input-end-mark)
- (save-excursion
- (goto-char slime-repl-input-end-mark)
- (recenter -1))))
- ((and (or (get-text-property (point) 'slime-repl-old-output)
- (get-text-property (1- (point)) 'slime-repl-old-output))
- (< (point) slime-repl-input-start-mark))
+ (slime-repl-recenter-if-needed))
+ ((and (car (slime-presentation-around-or-before-point (point)))
+ (< (point) slime-repl-input-start-mark))
(slime-repl-grab-old-output end-of-input)
- (unless (pos-visible-in-window-p slime-repl-input-end-mark)
- (save-excursion
- (goto-char slime-repl-input-end-mark)
- (recenter -1))))
- (end-of-input
- (slime-repl-send-input))
- (slime-repl-read-mode ; bad style?
+ (slime-repl-recenter-if-needed))
+ ((slime-input-complete-p slime-repl-input-start-mark
+ (ecase slime-repl-return-behaviour
+ (:send-only-if-after-complete (min (point) slime-repl-input-end-mark))
+ (:send-if-complete slime-repl-input-end-mark)))
(slime-repl-send-input t))
- ((slime-input-complete-p slime-repl-input-start-mark
- slime-repl-input-end-mark)
- (slime-repl-send-input t))
(t
(slime-repl-newline-and-indent)
(message "[input not complete]"))))
+(defun slime-repl-recenter-if-needed ()
+ "Make sure that slime-repl-input-end-mark is visible."
+ (unless (pos-visible-in-window-p slime-repl-input-end-mark)
+ (save-excursion
+ (goto-char slime-repl-input-end-mark)
+ (recenter -1))))
+
(defun slime-repl-send-input (&optional newline)
"Goto to the end of the input and send the current input.
If NEWLINE is true then add a newline at the end of the input."
(when (< (point) slime-repl-input-start-mark)
(error "No input at point."))
(goto-char slime-repl-input-end-mark)
- (when newline
- (insert "\n")
- (slime-repl-show-maximum-output))
- (let ((inhibit-read-only t))
- (add-text-properties slime-repl-input-start-mark (point)
- `(slime-repl-old-input
- ,(incf slime-repl-old-input-counter))))
- (let ((overlay (make-overlay slime-repl-input-start-mark (point))))
- ;; These properties are on an overlay so that they won't be taken
- ;; by kill/yank.
- (overlay-put overlay 'read-only t)
- (overlay-put overlay 'face 'slime-repl-input-face)
- (overlay-put overlay 'rear-nonsticky '(face slime-repl-old-input-counter)))
+ (let ((end (point))) ; end of input, without the newline
+ (when newline
+ (insert "\n")
+ (slime-repl-show-maximum-output))
+ (let ((inhibit-read-only t))
+ (add-text-properties slime-repl-input-start-mark
+ (point)
+ `(slime-repl-old-input
+ ,(incf slime-repl-old-input-counter))))
+ (let ((overlay (make-overlay slime-repl-input-start-mark end)))
+ ;; These properties are on an overlay so that they won't be taken
+ ;; by kill/yank.
+ (overlay-put overlay 'read-only t)
+ (overlay-put overlay 'face 'slime-repl-input-face)))
+ (slime-repl-add-to-input-history
+ (buffer-substring slime-repl-input-start-mark
+ slime-repl-input-end-mark))
+
(let ((input (slime-repl-current-input)))
(goto-char slime-repl-input-end-mark)
(slime-mark-input-start)
@@ -3010,7 +3799,7 @@
(defun slime-repl-grab-old-input (replace)
"Resend the old REPL input at point.
-If replace it non-nil the current input is replaced with the old
+If replace is non-nil the current input is replaced with the old
input; otherwise the new input is appended. The old input has the
text property `slime-repl-old-input'."
(multiple-value-bind (beg end) (slime-property-bounds 'slime-repl-old-input)
@@ -3029,9 +3818,9 @@
(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. The old output has the
-text property `slime-repl-old-output'."
- (multiple-value-bind (beg end) (slime-property-bounds 'slime-repl-old-output)
+output; otherwise the new input is appended."
+ (multiple-value-bind (presentation beg end)
+ (slime-presentation-around-or-before-point (point))
(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))
@@ -3040,9 +3829,7 @@
(insert " "))))
(delete-region (point) slime-repl-input-end-mark)
(let ((inhibit-read-only t))
- (slime-propertize-region
- '(face slime-repl-inputed-output-face)
- (insert old-output))))))
+ (insert old-output)))))
(defun slime-property-bounds (prop)
"Return two the positions of the previous and next changes to PROP.
@@ -3054,13 +3841,14 @@
;; forward one char to avoid doing the wrong thing if
;; we're at the beginning of the old input. -luke
;; (18/Jun/2004)
- (unless (not (get-text-property (point) 'slime-repl-old-output))
- ;alanr unless we are sitting right after it May 19, 2005
+ (unless (not (get-text-property (point) prop))
+ ;; alanr unless we are sitting right after it May 19, 2005
(ignore-errors (forward-char)))
(previous-single-char-property-change (point) prop)))
(end (save-excursion
- (if (get-text-property (point) 'slime-repl-old-output)
- (progn (goto-char (next-single-char-property-change (point) prop))
+ (if (get-text-property (point) prop)
+ (progn (goto-char (next-single-char-property-change
+ (point) prop))
(skip-chars-backward "\n \t\r" beg)
(point))
(point)))))
@@ -3090,6 +3878,12 @@
(defun slime-repl-delete-current-input ()
(delete-region slime-repl-input-start-mark slime-repl-input-end-mark))
+(defun slime-repl-kill-input ()
+ "Kill all text from last stuff output by the Lisp process to point."
+ (interactive)
+ (when (> (point) (marker-position slime-repl-input-start-mark))
+ (kill-region slime-repl-input-start-mark (point))))
+
(defun slime-repl-replace-input (string)
(slime-repl-delete-current-input)
(insert-and-inherit string))
@@ -3102,7 +3896,7 @@
(defun slime-repl-clear-buffer ()
"Delete the entire output generated by the Lisp process."
(interactive)
- (slime-eval `(swank::clear-repl-results))
+ (slime-eval-async `(swank:clear-repl-results))
(set-marker slime-repl-last-input-start-mark nil)
(let ((inhibit-read-only t))
(delete-region (point-min) (slime-repl-input-line-beginning-position))
@@ -3111,7 +3905,6 @@
(defun slime-repl-clear-output ()
"Delete the output inserted since the last input."
(interactive)
- (slime-eval `(swank::clear-last-repl-result))
(let ((start (save-excursion
(slime-repl-previous-prompt)
(ignore-errors (forward-sexp))
@@ -3135,7 +3928,7 @@
(slime-eval `(swank:set-package ,package))
(setf (slime-lisp-package) name)
(setf (slime-lisp-package-prompt-string) prompt-string)
- (slime-repl-insert-prompt "" 0)
+ (slime-repl-insert-prompt '(:suppress-output) 0)
(insert unfinished-input)))))
@@ -3149,14 +3942,31 @@
(defvar slime-repl-history-pattern nil
"The regexp most recently used for finding input history.")
-(defun slime-repl-history-replace (direction regexp &optional delete-at-end-p)
+;; initialized later when slime-repl-mode-map is available
+(defvar slime-repl-history-map (make-sparse-keymap)
+ "Map active while in the minibuffer reading repl search regexp.")
+
+(defun* slime-repl-history-replace (direction &optional regexp delete-at-end-p)
"Replace the current input with the next line in DIRECTION matching REGEXP.
DIRECTION is 'forward' or 'backward' (in the history list).
If DELETE-AT-END-P is non-nil then remove the string if the end of the
-history is reached."
- (setq slime-repl-history-pattern regexp)
- (let ((pos (slime-repl-position-in-history direction regexp))
- (forward (eq direction 'forward)))
+history is reached. Returns t if there were any matches."
+ (when regexp
+ (setq slime-repl-history-pattern regexp))
+ (let* ((forward (eq direction 'forward))
+ (history-length (length slime-repl-input-history))
+ (pos (if regexp
+ (slime-repl-position-in-history direction regexp)
+ (if (>= slime-repl-input-history-position 0)
+ (+ slime-repl-input-history-position
+ (if forward -1 1))
+ (unless forward
+ 0)))))
+ (when (and pos
+ (or (< pos 0)
+ (>= pos history-length)))
+
+ (setf pos nil))
(cond (pos
(slime-repl-replace-input (nth pos slime-repl-input-history))
(setq slime-repl-input-history-position pos)
@@ -3166,13 +3976,15 @@
(message "End of history"))
(t (message "Beginning of history")))
(setq slime-repl-input-history-position
- (if forward -1 (length slime-repl-input-history))))
+ (if forward -1 history-length)))
((and delete-at-end-p slime-repl-wrap-history)
(slime-repl-replace-input "")
(setq slime-repl-input-history-position
- (if forward (length slime-repl-input-history) -1)))
+ (if forward history-length -1)))
(t
- (message "End of history; no matching item")))))
+ (message "End of history; no matching item")
+ (return-from slime-repl-history-replace nil))))
+ t)
(defun slime-repl-position-in-history (direction regexp)
"Return the position of the history item matching regexp.
@@ -3181,37 +3993,172 @@
(let* ((step (ecase direction
(forward -1)
(backward 1)))
- (history-pos0 slime-repl-input-history-position))
+ (history-pos0 slime-repl-input-history-position)
+ (history-length (length slime-repl-input-history)))
(loop for pos = (+ history-pos0 step) then (+ pos step)
while (and (<= 0 pos)
- (< pos (length slime-repl-input-history)))
+ (< pos history-length))
do (let ((string (nth pos slime-repl-input-history)))
(when (and (string-match regexp string)
(not (string= string (slime-repl-current-input))))
(return pos))))))
+(defun slime-repl-previous-input ()
+ (interactive)
+ (slime-repl-history-replace 'backward nil t))
+
+(defun slime-repl-next-input ()
+ (interactive)
+ (slime-repl-history-replace 'forward nil t))
+
(defun slime-repl-matching-input-regexp ()
(if (memq last-command
- '(slime-repl-previous-input slime-repl-next-input))
+ '(slime-repl-previous-input-starting-with-current-input slime-repl-next-input-starting-with-current-input))
slime-repl-history-pattern
(concat "^" (regexp-quote (slime-repl-current-input)))))
-(defun slime-repl-previous-input ()
+(defun slime-repl-previous-input-starting-with-current-input ()
(interactive)
(slime-repl-history-replace 'backward (slime-repl-matching-input-regexp) t))
-(defun slime-repl-next-input ()
+(defun slime-repl-next-input-starting-with-current-input ()
(interactive)
(slime-repl-history-replace 'forward (slime-repl-matching-input-regexp) t))
-(defun slime-repl-previous-matching-input (regexp)
- (interactive "sPrevious element matching (regexp): ")
- (slime-repl-history-replace 'backward regexp))
+(defun slime-repl-continue-search-with-last-pattern ()
+ (interactive)
+ (when slime-repl-history-pattern
+ (throw 'continue slime-repl-history-pattern)))
-(defun slime-repl-next-matching-input (regexp)
- (interactive "sNext element matching (regexp): ")
- (slime-repl-history-replace 'forward regexp))
+(defun slime-repl-previous-or-next-matching-input (regexp direction prompt)
+ (let ((command this-command))
+ (unless regexp
+ (setf regexp (if (and slime-repl-history-pattern
+ (memq last-command
+ '(slime-repl-previous-matching-input slime-repl-next-matching-input)))
+ slime-repl-history-pattern
+ (catch 'continue
+ (slime-read-from-minibuffer
+ prompt (slime-symbol-name-at-point) slime-repl-history-map)))))
+ (when (and regexp (> (length regexp) 0))
+ (when (slime-repl-history-replace direction regexp)
+ (setf this-command command)))))
+(defun slime-repl-previous-matching-input ()
+ (interactive)
+ (slime-repl-previous-or-next-matching-input
+ nil 'backward "Previous element matching (regexp): "))
+
+(defun slime-repl-next-matching-input ()
+ (interactive)
+ (slime-repl-previous-or-next-matching-input
+ nil 'forward "Next element matching (regexp): "))
+
+;;;;; Persistent History
+
+(defun slime-repl-merge-histories (old-hist new-hist)
+ "Merge entries from OLD-HIST and NEW-HIST."
+ ;; Newer items in each list are at the beginning.
+ (append
+ ;; first the new unique elements...
+ (remove-if #'(lambda (entry)
+ (member entry old-hist))
+ new-hist)
+ ;; then the old unique elements...
+ (remove-if #'(lambda (entry)
+ (member entry new-hist))
+ old-hist)
+ ;; and finally elements existing in both lists
+ (remove-if #'(lambda (entry)
+ (not (member entry old-hist)))
+ new-hist)))
+
+(defun slime-repl-load-history (&optional filename)
+ "Set the current SLIME REPL history.
+It can be read either from FILENAME or `slime-repl-history-file' or
+from a user defined filename."
+ (interactive (list (slime-repl-read-history-filename)))
+ (let ((file (or filename slime-repl-history-file)))
+ (setq slime-repl-input-history (slime-repl-read-history file t))))
+
+(defun slime-repl-read-history (&optional filename noerrer)
+ "Read and return the history from FILENAME.
+The default value for FILENAME is `slime-repl-history-file'.
+If NOERROR is true return and the file doesn't exits return nil."
+ (let ((file (or filename slime-repl-history-file)))
+ (cond ((not (file-readable-p file)) '())
+ (t (with-temp-buffer
+ (insert-file-contents file)
+ (read (current-buffer)))))))
+
+(defun slime-repl-read-history-filename ()
+ (read-file-name "Use SLIME REPL history from file: "
+ slime-repl-history-file))
+
+(defun slime-repl-save-merged-history (&optional filename)
+ "Read the history file, merge the current REPL history and save it.
+This tries to be smart in merging the history from the file and the
+current history in that it tries to detect the unique entries using
+`slime-repl-merge-histories'."
+ (interactive (list (slime-repl-read-history-filename)))
+ (let ((file (or filename slime-repl-history-file)))
+ (message "saving history...")
+ (let ((hist (slime-repl-merge-histories (slime-repl-read-history file t)
+ slime-repl-input-history)))
+ (slime-repl-save-history file hist))))
+
+(defun slime-repl-save-history (&optional filename history)
+ "Simply save the current SLIME REPL history to a file.
+When SLIME is setup to always load the old history and one uses only
+one instance of slime all the time, there is no need to merge the
+files and this function is sufficient.
+
+When the list is longer than `slime-repl-history-size' it will be
+truncated. That part is untested, though!"
+ (interactive (list (slime-repl-read-history-filename)))
+ (let ((file (or filename slime-repl-history-file))
+ (hist (or history slime-repl-input-history)))
+ (unless (file-writable-p file)
+ (error (format "History file not writable: %s" file)))
+ (let ((hist (subseq hist 0 (min (length hist) slime-repl-history-size))))
+ ;;(message "saving %s to %s\n" hist file)
+ (with-temp-file file
+ (let ((cs slime-repl-history-file-coding-system))
+ (setq buffer-file-coding-system cs)
+ (insert (format ";; -*- coding: %s -*-\n" cs)))
+ (insert ";; History for SLIME REPL. Automatically written.\n"
+ ";; Edit only if you know what you're doing\n")
+ (pp (mapcar #'substring-no-properties hist) (current-buffer))))))
+
+(defun slime-repl-save-all-histories ()
+ "Save the history in each repl buffer."
+ (dolist (b (buffer-list))
+ (with-current-buffer b
+ (when (eq major-mode 'slime-repl-mode)
+ (slime-repl-safe-save-merged-history)))))
+
+(defun slime-repl-safe-save-merged-history ()
+ (slime-repl-call-with-handler
+ #'slime-repl-save-merged-history
+ "%S while saving the history. Continue? "))
+
+(defun slime-repl-safe-load-history ()
+ (slime-repl-call-with-handler
+ #'slime-repl-load-history
+ "%S while loading the history. Continue? "))
+
+(defun slime-repl-call-with-handler (fun query)
+ "Call FUN in the context of an error handler.
+The handler will use qeuery to ask the use if the error should be ingored."
+ (condition-case err
+ (funcall fun)
+ (error
+ (if (y-or-n-p (format query (error-message-string err)))
+ nil
+ (signal (car err) (cdr err))))))
+
+;;;;; REPL mode setup
+
(defun slime-repl ()
(interactive)
(slime-switch-to-output-buffer))
@@ -3234,9 +4181,9 @@
("\C-a" 'slime-repl-bol)
([home] 'slime-repl-bol)
("\C-e" 'slime-repl-eol)
- ("\M-p" 'slime-repl-previous-input)
+ ("\M-p" 'slime-repl-previous-input-starting-with-current-input)
((kbd "C-<up>") 'slime-repl-previous-input)
- ("\M-n" 'slime-repl-next-input)
+ ("\M-n" 'slime-repl-next-input-starting-with-current-input)
((kbd "C-<down>") 'slime-repl-next-input)
("\M-r" 'slime-repl-previous-matching-input)
("\M-s" 'slime-repl-next-matching-input)
@@ -3253,6 +4200,7 @@
("\C-\M-x" 'slime-eval-defun)
("\C-c\C-o" 'slime-repl-clear-output)
("\C-c\C-t" 'slime-repl-clear-buffer)
+ ("\C-c\C-u" 'slime-repl-kill-input)
("\C-c\C-n" 'slime-repl-next-prompt)
("\C-c\C-p" 'slime-repl-previous-prompt)
("\M-\C-a" 'slime-repl-beginning-of-defun)
@@ -3261,6 +4209,16 @@
("\C-c\C-k" 'slime-compile-and-load-file)
("\C-c\C-z" 'slime-nop))
+;; set up slime-repl-history-map
+(flet ((remap (keys to)
+ (mimic-key-bindings slime-repl-mode-map slime-repl-history-map keys to)))
+ (remap (list 'slime-repl-previous-matching-input (kbd "M-r"))
+ 'slime-repl-continue-search-with-last-pattern)
+ (remap (list 'slime-repl-next-matching-input (kbd "M-n"))
+ 'slime-repl-continue-search-with-last-pattern))
+
+;;;;;; REPL Read Mode
+
(define-key slime-repl-mode-map
(string slime-repl-shortcut-dispatch-char) 'slime-handle-repl-shortcut)
@@ -3288,10 +4246,8 @@
(slime-mark-input-start)
(slime-repl-read-mode 1))
-(defun evaluate-in-emacs (expr thread tag)
- (push thread slime-read-string-threads)
- (push tag slime-read-string-tags)
- (slime-repl-return-string (eval expr)))
+(defun slime-y-or-n-p (thread tag question)
+ (slime-dispatch-event `(:emacs-return ,thread ,tag ,(y-or-n-p question))))
(defun slime-repl-return-string (string)
(slime-dispatch-event `(:emacs-return-string
@@ -3302,7 +4258,7 @@
(defun slime-repl-read-break ()
(interactive)
- (slime-eval-async `(cl:break)))
+ (slime-dispatch-event `(:emacs-interrupt ,(car slime-read-string-threads))))
(defun slime-repl-abort-read (thread tag)
(with-current-buffer (slime-output-buffer)
@@ -3325,17 +4281,15 @@
(defun slime-handle-repl-shortcut ()
(interactive)
- (if (save-excursion
- (goto-char slime-repl-input-start-mark)
- (looking-at " *$"))
+ (if (> (point) slime-repl-input-start-mark)
+ (insert (string slime-repl-shortcut-dispatch-char))
(let ((shortcut (slime-lookup-shortcut
(completing-read "Command: "
(slime-bogus-completion-alist
(slime-list-all-repl-shortcuts))
nil t nil
'slime-repl-shortcut-history))))
- (call-interactively (slime-repl-shortcut.handler shortcut)))
- (insert (string slime-repl-shortcut-dispatch-char))))
+ (call-interactively (slime-repl-shortcut.handler shortcut)))))
(defun slime-list-all-repl-shortcuts ()
(loop for shortcut in slime-repl-shortcut-table
@@ -3384,6 +4338,13 @@
(insert (car names) ")"))
(insert "\n " (slime-repl-shortcut.one-liner shortcut)
"\n"))))))
+
+(defun slime-save-some-lisp-buffers ()
+ (if slime-repl-only-save-lisp-buffers
+ (save-some-buffers nil (lambda ()
+ (and (memq major-mode slime-lisp-modes)
+ (not (null buffer-file-name)))))
+ (save-some-buffers)))
(defslime-repl-shortcut slime-repl-shortcut-help ("help" "?")
(:handler 'slime-list-repl-short-cuts)
@@ -3400,43 +4361,48 @@
(message "Directory %s" dir))))
(:one-liner "Show the current directory."))
-(defslime-repl-shortcut slime-repl-push-directory ("push-directory" "+d"
- "pushd")
+(defslime-repl-shortcut slime-repl-push-directory
+ ("push-directory" "+d" "pushd")
(:handler (lambda (directory)
(interactive
- (list (read-directory-name
+ (list (read-directory-name
"Push directory: "
- (slime-eval '(swank:default-directory)) nil nil "")))
- (push directory slime-repl-directory-stack)
+ (slime-eval '(swank:default-directory))
+ nil nil "")))
+ (push (slime-eval '(swank:default-directory))
+ slime-repl-directory-stack)
(slime-set-default-directory directory)))
- (:one-liner "Push a new directory onto the directory stack."))
+ (:one-liner "Save the current directory and set it to a new one."))
-(defslime-repl-shortcut slime-repl-pop-directory ("pop-directory" "-d")
+(defslime-repl-shortcut slime-repl-pop-directory
+ ("pop-directory" "-d" "popd")
(:handler (lambda ()
(interactive)
- (unless (= 1 (length slime-repl-directory-stack))
- (pop slime-repl-directory-stack))
- (slime-set-default-directory (car slime-repl-directory-stack))))
- (:one-liner "Pop the current directory."))
+ (if (null slime-repl-directory-stack)
+ (message "Directory stack is empty.")
+ (slime-set-default-directory
+ (pop slime-repl-directory-stack)))))
+ (:one-liner "Restore the last saved directory."))
-(defslime-repl-shortcut nil ("change-package" "!p")
+(defslime-repl-shortcut nil ("change-package" "!p" "in-package" "in")
(:handler 'slime-repl-set-package)
(:one-liner "Change the current package."))
(defslime-repl-shortcut slime-repl-push-package ("push-package" "+p")
(:handler (lambda (package)
(interactive (list (slime-read-package-name "Package: ")))
- (push package slime-repl-package-stack)
+ (push (slime-lisp-package) slime-repl-package-stack)
(slime-repl-set-package package)))
- (:one-liner "Push a package onto the package stack."))
+ (:one-liner "Save the current package and set it to a new one."))
(defslime-repl-shortcut slime-repl-pop-package ("pop-package" "-p")
(:handler (lambda ()
(interactive)
- (unless (= 1 (length slime-repl-package-stack))
- (pop slime-repl-package-stack))
- (slime-repl-set-package (car slime-repl-package-stack))))
- (:one-liner "Pop the top of the package stack."))
+ (if (null slime-repl-package-stack)
+ (message "Package stack is empty.")
+ (slime-repl-set-package
+ (pop slime-repl-package-stack)))))
+ (:one-liner "Restore the last saved package."))
(defslime-repl-shortcut slime-repl-resend ("resend-form")
(:handler (lambda ()
@@ -3446,6 +4412,10 @@
(slime-repl-send-input)))
(:one-liner "Resend the last form."))
+(defslime-repl-shortcut slime-repl-disconnect ("disconnect")
+ (:handler 'slime-disconnect)
+ (:one-liner "Disconnect all connections."))
+
(defslime-repl-shortcut slime-repl-sayoonara ("sayoonara")
(:handler (lambda ()
(interactive)
@@ -3471,7 +4441,7 @@
(:handler (lambda (filename)
(interactive (list (expand-file-name
(read-file-name "File: " nil nil nil nil))))
- (save-some-buffers)
+ (slime-save-some-lisp-buffers)
(slime-eval-async
`(swank:compile-file-if-needed
,(slime-to-lisp-filename filename) t)
@@ -3503,13 +4473,15 @@
(slime-oos (slime-read-system-name) "COMPILE-OP" :force t)))
(:one-liner "Recompile (but not load) an ASDF system."))
-(defslime-repl-shortcut slime-restart-inferior-lisp ("restart-inferior-lisp")
- (:handler 'slime-restart-inferior-lisp-aux)
+(defslime-repl-shortcut nil ("restart-inferior-lisp")
+ (:handler 'slime-restart-inferior-lisp)
(:one-liner "Restart *inferior-lisp* and reconnect SLIME."))
-(defun slime-restart-inferior-lisp-aux ()
+(defun slime-restart-inferior-lisp ()
(interactive)
+ (assert (slime-inferior-process) () "No inferior lisp process")
(slime-eval-async '(swank:quit-lisp))
+ (set-process-filter (slime-connection) nil)
(set-process-sentinel (slime-connection) 'slime-restart-sentinel))
(defun slime-restart-sentinel (process message)
@@ -3517,14 +4489,16 @@
Also rearrange windows."
(assert (process-status process) 'closed)
(let* ((proc (slime-inferior-process process))
- (args (mapconcat #'identity (process-command proc) " "))
+ (args (slime-inferior-lisp-args proc))
(buffer (buffer-name (process-buffer proc)))
(buffer-window (get-buffer-window buffer))
- (new-proc (slime-start-lisp args buffer (slime-init-command)))
+ (new-proc (slime-start-lisp (plist-get args :program)
+ (plist-get args :program-args)
+ buffer))
(repl-buffer (slime-repl-buffer nil process))
(repl-window (and repl-buffer (get-buffer-window repl-buffer))))
(slime-net-close process)
- (slime-inferior-connect new-proc)
+ (slime-inferior-connect new-proc args)
(cond ((and repl-window (not buffer-window))
(set-window-buffer repl-window buffer)
(select-window repl-window))
@@ -3579,6 +4553,11 @@
;;;; Compilation and the creation of compiler-note annotations
+(defvar slime-before-compile-functions nil
+ "A list of function called before compiling a buffer or region.
+The function receive two arguments: the beginning and the end of the
+region that will be compiled.")
+
(defun slime-compile-and-load-file ()
"Compile and load the buffer's file and highlight compiler notes.
@@ -3598,18 +4577,21 @@
(interactive)
(unless (memq major-mode slime-lisp-modes)
(error "Only valid in lisp-mode"))
+ (check-parens)
(unless buffer-file-name
(error "Buffer %s is not associated with a file." (buffer-name)))
(when (and (buffer-modified-p)
(y-or-n-p (format "Save file %s? " (buffer-file-name))))
(save-buffer))
+ (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max))
(let ((lisp-filename (slime-to-lisp-filename (buffer-file-name))))
(slime-insert-transcript-delimiter
(format "Compile file %s" lisp-filename))
(when slime-display-compilation-output
(slime-display-output-buffer))
(slime-eval-async
- `(swank:compile-file-for-emacs ,lisp-filename ,(if load t nil))
+ `(swank:compile-file-for-emacs
+ ,lisp-filename ,(if load t nil))
(slime-compilation-finished-continuation))
(message "Compiling %s.." lisp-filename)))
@@ -3621,14 +4603,17 @@
(and asdf-systems-in-directory
(file-name-sans-extension (car asdf-systems-in-directory)))))
-(defun slime-load-system (&optional system-name)
+(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-name "LOAD-OP"))
+ (slime-oos system "LOAD-OP"))
+(defvar slime-system-history nil
+ "History list for ASDF system names.")
+
(defun slime-read-system-name (&optional prompt initial-value)
"Read a system name from the minibuffer, prompting with PROMPT."
(setq prompt (or prompt "System: "))
@@ -3638,30 +4623,28 @@
(slime-eval
`(swank:list-all-systems-in-central-registry))))))
(completing-read prompt alist nil nil
- (or initial-value (slime-find-asd) ""))))
+ (or initial-value (slime-find-asd) "")
+ 'slime-system-history)))
-(defun slime-oos (system-name operation &rest keyword-args)
- (save-some-buffers)
+(defun slime-oos (system operation &rest keyword-args)
+ (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-name)
+ system)
(slime-eval-async
- `(swank:operate-on-system-for-emacs ,system-name ,operation ,@keyword-args)
+ `(swank:operate-on-system-for-emacs ,system ,operation ,@keyword-args)
(slime-compilation-finished-continuation)))
(defun slime-compile-defun ()
"Compile the current toplevel form."
(interactive)
- (slime-compile-string (slime-defun-at-point)
- (save-excursion
- (end-of-defun)
- (beginning-of-defun)
- (point))))
+ (apply #'slime-compile-region (slime-region-for-defun-at-point)))
(defun slime-compile-region (start end)
"Compile the region."
(interactive "r")
+ (run-hook-with-args 'slime-before-compile-functions start end)
(slime-compile-string (buffer-substring-no-properties start end) start))
(defun slime-compile-string (string start-offset)
@@ -3673,8 +4656,6 @@
,(if (buffer-file-name) (file-name-directory (buffer-file-name))))
(slime-compilation-finished-continuation)))
-(defvar slime-hide-style-warning-count-if-zero t)
-
(defun slime-note-count-string (severity count &optional suppress-if-zero)
(cond ((and (zerop count) suppress-if-zero)
"")
@@ -3688,14 +4669,12 @@
(:warning (incf nwarnings))
(:style-warning (incf nstyle-warnings))
(:note (incf nnotes))))
- (message
- "Compilation finished:%s%s%s%s%s"
- (slime-note-count-string "error" nerrors)
- (slime-note-count-string "warning" nwarnings)
- (slime-note-count-string "style-warning" nstyle-warnings
- slime-hide-style-warning-count-if-zero)
- (slime-note-count-string "note" nnotes)
- (if secs (format "[%s secs]" secs) ""))))
+ (message "Compilation finished:%s%s%s%s%s"
+ (slime-note-count-string "error" nerrors)
+ (slime-note-count-string "warning" nwarnings)
+ (slime-note-count-string "style-warning" nstyle-warnings t)
+ (slime-note-count-string "note" nnotes)
+ (if secs (format "[%s secs]" secs) ""))))
(defun slime-xrefs-for-notes (notes)
(let ((xrefs))
@@ -3734,9 +4713,11 @@
(defun slime-compilation-finished (result buffer)
(let ((notes (slime-compiler-notes)))
(with-current-buffer buffer
+ (setf slime-compilation-just-finished t)
(multiple-value-bind (result secs) result
(slime-show-note-counts notes secs)
- (slime-highlight-notes notes)))
+ (when slime-highlight-compiler-notes
+ (slime-highlight-notes notes))))
(run-hook-with-args 'slime-compilation-finished-hook notes)))
(defun slime-compilation-finished-continuation ()
@@ -3747,9 +4728,10 @@
(defun slime-highlight-notes (notes)
"Highlight compiler notes, warnings, and errors in the buffer."
(interactive (list (slime-compiler-notes)))
- (save-excursion
- (slime-remove-old-overlays)
- (mapc #'slime-overlay-note (slime-merge-notes-for-display notes))))
+ (with-temp-message "Highlighting notes..."
+ (save-excursion
+ (slime-remove-old-overlays)
+ (mapc #'slime-overlay-note (slime-merge-notes-for-display notes)))))
(defun slime-compiler-notes ()
"Return all compiler notes, warnings, and errors."
@@ -3775,7 +4757,6 @@
(funcall predicate)))
(buffer-list)))
-
;;;;; Merging together compiler notes in the same location.
@@ -3845,19 +4826,20 @@
(defun slime-list-compiler-notes (&optional notes)
"Show the compiler notes NOTES in tree view."
(interactive)
- (let ((notes (or notes (slime-compiler-notes))))
- (with-current-buffer
- (slime-get-temp-buffer-create "*compiler notes*"
- :mode 'slime-compiler-notes-mode)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (when (null notes)
- (insert "[no notes]"))
- (dolist (tree (slime-compiler-notes-to-tree notes))
- (slime-tree-insert tree "")
- (insert "\n")))
- (setq buffer-read-only t)
- (goto-char (point-min)))))
+ (with-temp-message "Preparing compiler note tree..."
+ (let ((notes (or notes (slime-compiler-notes))))
+ (with-current-buffer
+ (slime-get-temp-buffer-create "*compiler notes*"
+ :mode 'slime-compiler-notes-mode)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (when (null notes)
+ (insert "[no notes]"))
+ (dolist (tree (slime-compiler-notes-to-tree notes))
+ (slime-tree-insert tree "")
+ (insert "\n")))
+ (setq buffer-read-only t)
+ (goto-char (point-min))))))
(defun slime-alistify (list key test)
"Partition the elements of LIST into an alist. KEY extracts the key
@@ -4130,18 +5112,22 @@
(defun slime-choose-overlay-region (note)
"Choose the start and end points for an overlay over NOTE.
If the location's sexp is a list spanning multiple lines, then the
-region around the first element is used."
+region around the first element is used.
+Return nil if there's no useful source location."
(let ((location (slime-note.location note)))
- (destructure-case location
- ((:error msg) ) ; do nothing
- ((:location _file pos _hints)
- (destructure-case pos
- ((:position pos &optional alignp)
- (if (eq (slime-note.severity note) :read-error)
- (values pos (1+ pos))
- (slime-choose-overlay-for-sexp location)))
- (t
- (slime-choose-overlay-for-sexp location)))))))
+ (when location
+ (destructure-case location
+ ((:error _) _ nil) ; do nothing
+ ((:location file pos _hints)
+ (cond ((eq (car file) ':source-form) nil)
+ (t
+ (destructure-case pos
+ ((:position pos &optional alignp)
+ (if (eq (slime-note.severity note) :read-error)
+ (values pos (1+ pos))
+ (slime-choose-overlay-for-sexp location)))
+ (t
+ (slime-choose-overlay-for-sexp location))))))))))
(defun slime-choose-overlay-for-sexp (location)
(slime-goto-source-location location)
@@ -4152,13 +5138,13 @@
(values start (point))
(values (1+ start)
(progn (goto-char (1+ start))
- (or (forward-sexp 1)
- (point)))))))
+ (ignore-errors (forward-sexp 1))
+ (point))))))
(defun slime-same-line-p (pos1 pos2)
"Return t if buffer positions POS1 and POS2 are on the same line."
- (save-excursion (goto-char (min pos1 pos2))
- (<= (max pos1 pos2) (line-end-position))))
+ (save-excursion (goto-char (min pos1 pos2))
+ (<= (max pos1 pos2) (line-end-position))))
(defun slime-severity-face (severity)
"Return the name of the font-lock face representing SEVERITY."
@@ -4212,7 +5198,10 @@
(defun slime-goto-location-buffer (buffer)
(destructure-case buffer
((:file filename)
- (set-buffer (find-file-noselect (slime-from-lisp-filename filename) t))
+ (let ((emacs-filename (slime-from-lisp-filename filename)))
+ (unless (and (buffer-file-name)
+ (string= (buffer-file-name) emacs-filename))
+ (set-buffer (find-file-noselect emacs-filename t))))
(goto-char (point-min)))
((:buffer buffer)
(set-buffer buffer)
@@ -4220,6 +5209,7 @@
((:source-form string)
(set-buffer (get-buffer-create "*SLIME Source Form*"))
(erase-buffer)
+ (lisp-mode)
(insert string)
(goto-char (point-min)))))
@@ -4231,7 +5221,8 @@
(slime-forward-sexp)
(beginning-of-sexp)))
((:line start &optional end)
- (goto-line start))
+ (goto-line start)
+ (skip-chars-forward " \t"))
((:function-name name)
(let ((case-fold-search t)
(name (regexp-quote name)))
@@ -4239,25 +5230,12 @@
(re-search-forward
(format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\S_" name) nil t)
(re-search-forward
- ;; FIXME: Isn't this far to general?
+ (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" name) nil t)
+ (re-search-forward
(format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t)))
(goto-char (match-beginning 0)))
- ;; Looks for a sequence of words (def<something> method name
- ;; qualifers specializers don't look for "T" since it isn't
- ;; requires (arg without t) as class is taken as such.
((:method name specializers &rest qualifiers)
- (let* ((case-fold-search t)
- (name (regexp-quote name))
- (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>"))
- qualifiers ""))
- (specializers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>"))
- (remove "T" specializers) ""))
- (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\>%s%s" name
- qualifiers specializers)))
- (or (and (re-search-forward regexp nil t)
- (goto-char (match-beginning 0)))
- ;; (slime-goto-location-position `(:function-name ,name))
- )))
+ (slime-search-method-location name specializers qualifiers))
((:source-path source-path start-position)
(cond (start-position
(goto-char start-position)
@@ -4271,6 +5249,29 @@
(slime-isearch text)
(forward-char delta))))
+(defun slime-search-method-location (name specializers qualifiers)
+ ;; Look for a sequence of words (def<something> method name
+ ;; qualifers specializers don't look for "T" since it isn't requires
+ ;; (arg without t) as class is taken as such.
+ (let* ((case-fold-search t)
+ (name (regexp-quote name))
+ (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>"))
+ qualifiers ""))
+ (specializers (mapconcat (lambda (el)
+ (if (eql (aref el 0) ?\()
+ (let ((spec (read el)))
+ (if (eq (car spec) 'EQL)
+ (concat ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" (format "%s" (second spec)) ")")
+ (error "don't understand specializer: %s,%s" el (car spec))))
+ (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>")))
+ (remove "T" specializers) ""))
+ (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name
+ qualifiers specializers)))
+ (or (and (re-search-forward regexp nil t)
+ (goto-char (match-beginning 0)))
+ ;; (slime-goto-location-position `(:function-name ,name))
+ )))
+
(defun slime-search-call-site (fname)
"Move to the place where FNAME called.
Don't move if there are multiple or no calls in the current defun."
@@ -4283,7 +5284,6 @@
(goto-char (match-beginning 0)))
(t (goto-char start))))))
-
(defun slime-goto-source-location (location &optional noerror)
"Move to the source location LOCATION. Several kinds of locations
are supported:
@@ -4430,21 +5430,40 @@
;;;;; Visiting and navigating the overlays of compiler notes
+(defvar slime-compilation-just-finished nil
+ "A buffer local variable which is T when we've just compiled a
+buffer and haven't yet started navigating its notes.")
+(make-variable-buffer-local 'slime-compilation-just-finished)
+
(defun slime-next-note ()
"Go to and describe the next compiler note in the buffer."
(interactive)
- (slime-find-next-note)
- (if (slime-note-at-point)
- (slime-show-note (slime-note-at-point))
- (message "No next note.")))
+ (let ((here (point)))
+ (when (and slime-goto-first-note-after-compilation
+ slime-compilation-just-finished)
+ (goto-char (point-min))
+ (setf slime-compilation-just-finished nil))
+ (slime-find-next-note)
+ (if (slime-note-at-point)
+ (slime-show-note (slime-note-at-point))
+ (progn
+ (goto-char here)
+ (message "No next note.")))))
(defun slime-previous-note ()
"Go to and describe the previous compiler note in the buffer."
(interactive)
- (slime-find-previous-note)
- (if (slime-note-at-point)
- (slime-show-note (slime-note-at-point))
- (message "No previous note.")))
+ (let ((here (point)))
+ (when (and slime-goto-first-note-after-compilation
+ slime-compilation-just-finished)
+ (goto-char (point-max))
+ (setf slime-compilation-just-finished nil))
+ (slime-find-previous-note)
+ (if (slime-note-at-point)
+ (slime-show-note (slime-note-at-point))
+ (progn
+ (goto-char here)
+ (message "No previous note.")))))
(defun slime-remove-notes ()
"Remove compiler-note annotations from the current buffer."
@@ -4515,23 +5534,32 @@
Designed to be bound to the SPC key. Prefix argument can be used to insert
more than one space."
(interactive "p")
+ (self-insert-command n)
(unwind-protect
(when (and slime-space-information-p
(slime-background-activities-enabled-p))
- (slime-echo-arglist))
- (self-insert-command n)))
+ (slime-echo-arglist))))
+(defun slime-fontify-string (string)
+ "Fontify STRING as `font-lock-mode' does in Lisp mode."
+ (with-current-buffer (get-buffer-create " *slime-fontify*")
+ (erase-buffer)
+ (if (not (eq major-mode 'lisp-mode))
+ (lisp-mode))
+ (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 highlight) highlight)))
+ (buffer-substring (point-min) (point-max))))
+
(defun slime-echo-arglist ()
"Display the arglist of the current form in the echo area."
- (let ((names (slime-enclosing-operator-names)))
- (when names
- (slime-eval-async
- `(swank:arglist-for-echo-area (quote ,names))
- (lexical-let ((buffer (current-buffer)))
- (lambda (message)
- (if message
- (with-current-buffer buffer
- (slime-message "%s" message)))))))))
+ (slime-autodoc))
(defun slime-arglist (name)
"Show the argument list for NAME."
@@ -4539,7 +5567,9 @@
(slime-eval-async
`(swank:arglist-for-echo-area (quote (,name)))
(lambda (arglist)
- (message "%s" arglist))))
+ (if arglist
+ (message "%s" (slime-fontify-string arglist))
+ (error "Arglist not available")))))
(defun slime-insert-arglist (name)
"Insert the argument list for NAME behind the symbol point is
@@ -4557,8 +5587,8 @@
(insert arglist))))))
(defun slime-complete-form ()
- "Complete the form at point. This is a superset of the
-functionality of `slime-insert-arglist'."
+ "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* ((start (save-excursion (backward-up-list 1) (point)))
@@ -4571,7 +5601,10 @@
(progn
(just-one-space)
(save-excursion
- (insert result)))))))
+ (insert result))
+ (save-excursion
+ (backward-up-list 1)
+ (indent-sexp)))))))
(defun slime-get-arglist (symbol-name)
"Return the argument list for SYMBOL-NAME."
@@ -4604,38 +5637,109 @@
(arg (setq slime-autodoc-mode t))
(t (setq slime-autodoc-mode (not slime-autodoc-mode))))
(if slime-autodoc-mode
- (slime-autodoc-start-timer)
+ (progn
+ (slime-autodoc-start-timer)
+ (add-hook 'pre-command-hook
+ 'slime-autodoc-pre-command-refresh-echo-area t))
(slime-autodoc-stop-timer)))
+(defvar slime-autodoc-last-message "")
+
(defun slime-autodoc ()
"Print some apropos information about the code at point, if applicable."
- (when-let (name (or (slime-autodoc-global-at-point)
- (slime-function-called-at-point/line)))
- (let ((cache-key (slime-qualify-cl-symbol-name name)))
- (or (when-let (documentation (slime-get-cached-autodoc cache-key))
- (slime-background-message "%s" documentation)
- t)
- ;; Asynchronously fetch, cache, and display documentation
- (slime-eval-async
- (if (slime-global-variable-name-p name)
- `(swank:variable-desc-for-echo-area ,name)
- `(swank:arglist-for-echo-area '(,name)))
- (with-lexical-bindings (cache-key name)
- (lambda (doc)
- (when (null doc)
- (setq doc ""))
+ (destructuring-bind (cache-key retrieve-form) (slime-autodoc-thing-at-point)
+ (let ((cached (slime-get-cached-autodoc cache-key)))
+ (if cached
+ (slime-autodoc-message cached)
+ ;; Asynchronously fetch, cache, and display documentation
+ (slime-eval-async
+ retrieve-form
+ (with-lexical-bindings (cache-key)
+ (lambda (doc)
+ (let ((doc (if doc (slime-fontify-string doc) "")))
(slime-update-autodoc-cache cache-key doc)
- (slime-background-message "%s" doc))))))))
+ (slime-autodoc-message doc)))))))))
+(defcustom slime-autodoc-use-multiline-p nil
+ "If non-nil, allow long autodoc messages to resize echo area display."
+ :type 'boolean
+ :group 'slime-ui)
+
+(defun slime-autodoc-message (doc)
+ "Display the autodoc documentation string DOC."
+ (cond
+ ((slime-typeout-active-p)
+ (setq slime-autodoc-last-message "") ; no need for refreshing
+ (slime-typeout-message doc))
+ (t
+ (unless slime-autodoc-use-multiline-p
+ (setq doc (slime-oneliner doc)))
+ (setq slime-autodoc-last-message doc)
+ (message "%s" doc))))
+
+(defun slime-autodoc-message-dimensions ()
+ "Return the available width and height for pretty printing autodoc
+messages."
+ (cond
+ ((slime-typeout-active-p)
+ ;; Use the full width of the typeout window;
+ ;; we don't care about the height, as typeout window can be scrolled
+ (values (window-width slime-typeout-window)
+ nil))
+ (slime-autodoc-use-multiline-p
+ ;; Use the full width of the minibuffer;
+ ;; minibuffer will grow vertically if necessary
+ (values (window-width (minibuffer-window))
+ nil))
+ (t
+ ;; Try to fit everything in one line; we cut off when displaying
+ (values 1000 1))))
+
+(defun slime-autodoc-pre-command-refresh-echo-area ()
+ (unless (string= slime-autodoc-last-message "")
+ (if (slime-autodoc-message-ok-p)
+ (message "%s" slime-autodoc-last-message)
+ (setq slime-autodoc-last-message ""))))
+
+(defun slime-autodoc-thing-at-point ()
+ "Return a cache key and a swank form."
+ (let ((global (slime-autodoc-global-at-point)))
+ (if global
+ (values (slime-qualify-cl-symbol-name global)
+ `(swank:variable-desc-for-echo-area ,global))
+ (multiple-value-bind (operators arg-indices)
+ (slime-enclosing-operator-names)
+ (values (mapcar* (lambda (designator arg-index)
+ (cons
+ (if (symbolp designator)
+ (slime-qualify-cl-symbol-name designator)
+ designator)
+ arg-index))
+ operators arg-indices)
+ (multiple-value-bind (width height)
+ (slime-autodoc-message-dimensions)
+ `(swank:arglist-for-echo-area ',operators
+ :arg-indices ',arg-indices
+ :print-right-margin ,width
+ :print-lines ,height)))))))
+
(defun slime-autodoc-global-at-point ()
"Return the global variable name at point, if any."
(when-let (name (slime-symbol-name-at-point))
(if (slime-global-variable-name-p name) name)))
+(defcustom slime-global-variable-name-regexp "^\\(.*:\\)?\\([*+]\\).+\\2$"
+ "Regexp used to check if a symbol name is a global variable.
+
+Default value assumes +this+ or *that* naming conventions."
+ :type 'regexp
+ :group 'slime)
+
(defun slime-global-variable-name-p (name)
"Is NAME a global variable?
Globals are recognised purely by *this-naming-convention*."
- (string-match "^\\(.*::?\\)?[*+].*[*+]$" name))
+ (and (< (length name) 80) ; avoid overflows in regexp matcher
+ (string-match slime-global-variable-name-regexp name)))
(defun slime-get-cached-autodoc (symbol-name)
"Return the cached autodoc documentation for SYMBOL-NAME, or nil."
@@ -4698,9 +5802,11 @@
(defun slime-autodoc-message-ok-p ()
"Return true if printing a message is currently okay (shouldn't
annoy the user)."
- (and slime-mode
+ (and (or slime-mode (eq major-mode 'slime-repl-mode)
+ (eq major-mode 'sldb-mode))
slime-autodoc-mode
- (null (current-message))
+ (or (null (current-message))
+ (string= (current-message) slime-autodoc-last-message))
(not executing-kbd-macro)
(not (and (boundp 'edebug-active) (symbol-value 'edebug-active)))
(not cursor-in-echo-area)
@@ -4746,6 +5852,85 @@
(slime-make-typeout-frame)))
+;;;; edit highlighting
+
+(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)))
+
+(defun slime-highlight-edits (beg end &optional len)
+ (save-match-data
+ (when (and (slime-connected-p)
+ (not (slime-inside-comment-p beg end))
+ (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-inside-comment-p (beg end)
+ "Is the region from BEG to END in a comment?"
+ (save-excursion
+ (goto-char beg)
+ (let* ((hs-c-start-regexp ";\\|#|")
+ (comment (hs-inside-comment-p)))
+ (and comment
+ (destructuring-bind (cbeg cend) comment
+ (<= end cend))))))
+
+(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))))
+
+
;;;; Completion
;; XXX those long names are ugly to read; long names an indicator for
@@ -4853,7 +6038,7 @@
(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-completions prefix))
+ (completion-result (slime-contextual-completions beg end))
(completion-set (first completion-result))
(completed-prefix (second completion-result)))
(if (null completion-set)
@@ -4876,14 +6061,24 @@
(when (member completed-prefix completion-set)
(slime-minibuffer-respecting-message
"Complete but not unique"))
- (let ((unambiguous-completion-length
- (loop for c in completion-set
- minimizing (or (mismatch completed-prefix c)
- (length completed-prefix)))))
- (goto-char (+ beg unambiguous-completion-length))
- (slime-display-completion-list completion-set
- completed-prefix)
- (slime-complete-delay-restoration)))))))
+ (if (and (eq last-command this-command)
+ (slime-completion-window-active-p))
+ ;; Scroll the completions window only
+ (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) nil)
+ (let ((other-window-scroll-buffer
+ (window-buffer window)))
+ (scroll-other-window)))))
+ (let ((unambiguous-completion-length
+ (loop for c in completion-set
+ minimizing (or (mismatch completed-prefix c)
+ (length completed-prefix)))))
+ (goto-char (+ beg unambiguous-completion-length))
+ (slime-display-completion-list completion-set
+ completed-prefix)
+ (slime-complete-delay-restoration))))))))
(defun slime-complete-symbol*-fancy-bit ()
"Do fancy tricks after completing a symbol.
@@ -4937,7 +6132,9 @@
Return nil iff if point is not at filename."
(if (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t))
(let ((comint-completion-addsuffix '("/" . "\"")))
- (comint-dynamic-complete-as-filename)
+ (if slime-when-complete-filename-expand
+ (comint-replace-by-expanded-filename)
+ (comint-dynamic-complete-as-filename))
t)
nil))
@@ -4954,6 +6151,7 @@
"Minibuffer keymap used for reading CL expressions.")
(set-keymap-parent slime-read-expression-map minibuffer-local-map)
+(set-keymap-parent slime-repl-history-map slime-read-expression-map)
(define-key slime-read-expression-map "\t" 'slime-complete-symbol)
(define-key slime-read-expression-map "\M-\t" 'slime-complete-symbol)
@@ -4961,7 +6159,7 @@
(defvar slime-read-expression-history '()
"History list of expressions read from the minibuffer.")
-(defun slime-read-from-minibuffer (prompt &optional initial-value)
+(defun slime-read-from-minibuffer (prompt &optional initial-value keymap)
"Read a string from the minibuffer, prompting with PROMPT.
If INITIAL-VALUE is non-nil, it is inserted into the minibuffer before
reading input. The result is a string (\"\" if no input was given)."
@@ -4973,7 +6171,8 @@
(setq slime-buffer-connection connection)
(set-syntax-table lisp-mode-syntax-table)))
minibuffer-setup-hook)))
- (read-from-minibuffer prompt initial-value slime-read-expression-map
+ (read-from-minibuffer prompt initial-value
+ (or keymap slime-read-expression-map)
nil 'slime-read-expression-history)))
(defun slime-bogus-completion-alist (list)
@@ -4983,12 +6182,50 @@
alist but ignores CDRs."
(mapcar (lambda (x) (cons x nil)) list))
+(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
+ (multiple-value-bind (operator-names arg-indices)
+ (save-excursion
+ (goto-char beg)
+ (slime-enclosing-operator-names))
+ (when operator-names
+ (let ((completions
+ (slime-completions-for-keyword operator-names token
+ arg-indices)))
+ (when (first completions)
+ (return-from slime-contextual-completions completions))
+ ;; If no matching keyword was found, do regular symbol
+ ;; completion.
+ ))))
+ ((and (> beg 2)
+ (string= (buffer-substring-no-properties (- beg 2) beg) "#\\"))
+ ;; Character name completion
+ (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))))
+ (slime-eval `(swank:completions ,prefix ',(slime-current-package))))
(defun slime-simple-completions (prefix)
- (slime-eval `(swank:simple-completions ,prefix ,(slime-current-package))))
+ (slime-eval `(swank:simple-completions ,prefix ',(slime-current-package))))
+(defun slime-completions-for-keyword (operator-designator prefix
+ arg-indices)
+ (slime-eval `(swank:completions-for-keyword ',operator-designator
+ ,prefix
+ ',arg-indices)))
+
+(defun slime-completions-for-character (prefix)
+ (slime-eval `(swank:completions-for-character ,prefix)))
+
;;;; Fuzzy completion
@@ -5018,6 +6255,9 @@
"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.")
(define-derived-mode slime-fuzzy-completions-mode
fundamental-mode "Fuzzy Completions"
@@ -5029,23 +6269,34 @@
(defvar slime-fuzzy-completions-map
(let* ((map (make-sparse-keymap)))
+ (flet ((remap (keys to)
+ (mimic-key-bindings global-map map keys to)))
+ (remap (list 'keyboard-quit (kbd "C-g")) 'slime-fuzzy-abort)
+ (define-key map "q" 'slime-fuzzy-abort)
- (define-key map "q" 'slime-fuzzy-abort)
- (define-key map "\r" 'slime-fuzzy-select)
+ (remap (list 'previous-line (kbd "<up>")) 'slime-fuzzy-prev)
+ (remap (list 'next-line (kbd "<down>")) 'slime-fuzzy-next)
- (define-key map "n" 'slime-fuzzy-next)
- (define-key map "\M-n" 'slime-fuzzy-next)
+ (define-key map "n" 'slime-fuzzy-next)
+ (define-key map "\M-n" 'slime-fuzzy-next)
- (define-key map "p" 'slime-fuzzy-prev)
- (define-key map "\M-p" 'slime-fuzzy-prev)
+ (define-key map "p" 'slime-fuzzy-prev)
+ (define-key map "\M-p" 'slime-fuzzy-prev)
- (define-key map "\d" 'scroll-down)
- (define-key map " " 'scroll-up)
+ (define-key map "\d" 'scroll-down)
+
+ (remap (list 'slime-fuzzy-indent-and-complete-symbol
+ 'slime-indent-and-complete-symbol
+ (kbd "<tab>"))
+ 'slime-fuzzy-select)
+
+ (define-key map (kbd "<mouse-2>") 'slime-fuzzy-select/mouse))
- (define-key map [mouse-2] 'slime-fuzzy-select/mouse)
+ (define-key map (kbd "RET") 'slime-fuzzy-select)
+ (define-key map (kbd "<SPC>") 'slime-fuzzy-select)
map)
- "Keymap for slime-fuzzy-completions-mode.")
+ "Keymap for slime-fuzzy-completions-mode when in the completion buffer.")
(defun slime-fuzzy-completions (prefix &optional default-package)
"Get the list of sorted completion objects from completing
@@ -5056,7 +6307,9 @@
(slime-eval `(swank:fuzzy-completions ,prefix
,(or default-package
(slime-find-buffer-package)
- (slime-current-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
@@ -5066,12 +6319,29 @@
(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))))))
+
(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))
(return-from slime-fuzzy-complete-symbol
- (comint-dynamic-complete-as-filename)))
+ (if slime-when-complete-filename-expand
+ (comint-replace-by-expanded-filename)
+ (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))
@@ -5080,13 +6350,14 @@
(progn (slime-minibuffer-respecting-message
"Can't find completion for \"%s\"" prefix)
(ding)
- (slime-complete-restore-window-configuration))
+ (slime-fuzzy-done))
(goto-char end)
(cond ((= (length completion-set) 1)
(insert-and-inherit (caar completion-set))
(delete-region beg end)
(goto-char (+ beg (length (caar completion-set))))
- (slime-minibuffer-respecting-message "Sole completion"))
+ (slime-minibuffer-respecting-message "Sole completion")
+ (slime-fuzzy-done))
;; Incomplete
(t
(slime-minibuffer-respecting-message "Complete but not unique")
@@ -5162,13 +6433,26 @@
`end'. This saves the window configuration before popping the
buffer so that it can possibly be restored when the user is
done."
- (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-save-window-configuration)
+ (let ((new-completion-buffer (not slime-fuzzy-target-buffer)))
+ (when new-completion-buffer
+ (slime-fuzzy-save-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)
+ (pop-to-buffer (slime-get-fuzzy-buffer))
+ (when new-completion-buffer
+ (add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort))
+ (when slime-fuzzy-completion-in-place
+ ;; switch back to the original buffer
+ (switch-to-buffer-other-window slime-fuzzy-target-buffer))))
+
+(defun slime-fuzzy-fill-completions-buffer (completions)
+ "Erases and fills the completion buffer with the given completions."
(with-current-buffer (slime-get-fuzzy-buffer)
(setq buffer-read-only nil)
(erase-buffer)
@@ -5188,12 +6472,21 @@
(setq buffer-read-only t))
(setq slime-fuzzy-current-completion
(caar completions))
- (slime-fuzzy-insert (caar completions))
- (goto-char slime-fuzzy-first)
- (pop-to-buffer (current-buffer))
- (add-hook (make-local-variable 'post-command-hook)
- 'slime-fuzzy-post-command-hook)))
+ (goto-char 0)
+ (slime-fuzzy-next)))
+(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
@@ -5224,23 +6517,43 @@
"Moves point directly to the next completion in the completions
buffer."
(interactive)
- (goto-char
- (next-single-char-property-change (point) 'completion)))
+ (with-current-buffer (slime-get-fuzzy-buffer)
+ (slime-fuzzy-dehighlight-current-completion)
+ (let ((point (next-single-char-property-change (point) 'completion)))
+ (when (= point (point-max))
+ (setf point (previous-single-char-property-change (point-max) '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-prev ()
"Moves point directly to the previous completion in the
completions buffer."
(interactive)
- (goto-char (previous-single-char-property-change
- (point) 'completion
- nil slime-fuzzy-first)))
+ (with-current-buffer (slime-get-fuzzy-buffer)
+ (slime-fuzzy-dehighlight-current-completion)
+ (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-dehighlight-current-completion ()
+ "Restores the original face for the current completion."
+ (when slime-fuzzy-current-completion-overlay
+ (overlay-put slime-fuzzy-current-completion-overlay 'face 'nil)))
+
+(defun slime-fuzzy-highlight-current-completion ()
+ "Highlights the current completion, so that the user can see it on the screen."
+ (let ((pos (point)))
+ (setq slime-fuzzy-current-completion-overlay (make-overlay (point) (search-forward " ") (current-buffer) t nil))
+ (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-insert slime-fuzzy-original-text)
(slime-fuzzy-done)))
(defun slime-fuzzy-select ()
@@ -5257,6 +6570,36 @@
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
@@ -5274,18 +6617,18 @@
and attempts to restore the window configuration. If this fails,
it just burys the completions buffer and leaves the window
configuration alone."
- (set-buffer slime-fuzzy-target-buffer)
- (remove-hook 'post-command-hook
- 'slime-fuzzy-post-command-hook)
- (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))
- (pop-to-buffer slime-fuzzy-target-buffer)
- (goto-char slime-fuzzy-end)
- (setq slime-fuzzy-target-buffer nil))
+ (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))
+ (pop-to-buffer slime-fuzzy-target-buffer)
+ (goto-char slime-fuzzy-end)
+ (setq slime-fuzzy-target-buffer nil)))
(defun slime-fuzzy-save-window-configuration ()
"Saves the current window configuration, and (if the
@@ -5354,36 +6697,51 @@
dspec location)
(defun slime-edit-definition (name &optional where)
- "Lookup the definition of the symbol at point.
-If there's no symbol at point, or a prefix argument is given, then the
+ "Lookup the definition of the name at point.
+If there's no name at point, or a prefix argument is given, then the
function name is prompted."
- (interactive (list (slime-read-symbol-name "Symbol: ")))
+ (interactive (list (slime-read-symbol-name "Name: ")))
(let ((definitions (slime-eval `(swank:find-definitions-for-emacs ,name))))
- (if (null definitions)
- (if slime-edit-definition-fallback-function
- (funcall slime-edit-definition-fallback-function name)
- (error "No known definition for: %s" name))
- (slime-goto-definition name definitions where))))
+ (cond
+ ((null definitions)
+ (if slime-edit-definition-fallback-function
+ (funcall slime-edit-definition-fallback-function name)
+ (error "No known definition for: %s" name)))
+ ((and (consp definitions) (null (cdr definitions))
+ (eql (car (slime-definition.location (car definitions))) :error))
+ (if slime-edit-definition-fallback-function
+ (funcall slime-edit-definition-fallback-function name)
+ (error "%s" (cadr (slime-definition.location (car definitions))))))
+ (t
+ (slime-goto-definition name definitions where)))))
(defun slime-goto-definition (name definitions &optional where)
(slime-push-definition-stack)
- (if (slime-length> definitions 1)
- (slime-show-definitions name definitions)
- (let ((def (car definitions)))
- (destructure-case (slime-definition.location def)
- ;; Take care of errors before switching any windows/buffers.
- ((:error message)
- (error "%s" message))
- (t
- (cond ((equal where 'window)
- (slime-goto-definition-other-window (car definitions)))
- ((equal where 'frame)
- (let ((pop-up-frames t))
- (slime-goto-definition-other-window (car definitions))))
- (t
- (slime-goto-source-location (slime-definition.location
- (car definitions)))
- (switch-to-buffer (current-buffer)))))))))
+ (let ((all-locations-equal
+ (or (null definitions)
+ (let ((first-location (slime-definition.location (first definitions))))
+ (every (lambda (definition)
+ (equal (slime-definition.location definition)
+ first-location))
+ (rest definitions))))))
+ (if (and (slime-length> definitions 1)
+ (not all-locations-equal))
+ (slime-show-definitions name definitions)
+ (let ((def (car definitions)))
+ (destructure-case (slime-definition.location def)
+ ;; Take care of errors before switching any windows/buffers.
+ ((:error message)
+ (error "%s" message))
+ (t
+ (cond ((equal where 'window)
+ (slime-goto-definition-other-window (car definitions)))
+ ((equal where 'frame)
+ (let ((pop-up-frames t))
+ (slime-goto-definition-other-window (car definitions))))
+ (t
+ (slime-goto-source-location (slime-definition.location
+ (car definitions)))
+ (switch-to-buffer (current-buffer))))))))))
(defun slime-goto-definition-other-window (definition)
(slime-pop-to-other-window)
@@ -5452,9 +6810,9 @@
(save-excursion
(save-match-data
(when (and (buffer-file-name)
- (slime-connected-p))
- (let ((filename (slime-to-lisp-filename (buffer-file-name))))
- (slime-eval-async `(swank:buffer-first-change ,filename)))))))
+ (slime-background-activities-enabled-p))
+ (let ((filename (slime-to-lisp-filename (buffer-file-name))))
+ (slime-eval-async `(swank:buffer-first-change ,filename)))))))
(defun slime-setup-first-change-hook ()
(add-hook (make-local-variable 'first-change-hook)
@@ -5465,24 +6823,32 @@
;;;; Eval for Lisp
-(defun slime-eval-for-lisp (thread tag fun args)
+(defun slime-eval-for-lisp (thread tag form-string)
(let ((ok nil)
(value nil)
(c (slime-connection)))
- (unwind-protect (progn
- (setq value (apply fun args))
+ (unwind-protect (progn
+ (slime-check-eval-in-emacs-enabled)
+ (setq value (eval (read form-string)))
(setq ok t))
(let ((result (if ok `(:ok ,value) `(:abort))))
- (slime-dispatch-event `(:emacs-return ,thread ,tag ,result))))))
+ (slime-dispatch-event `(:emacs-return ,thread ,tag ,result) c)))))
+(defun slime-check-eval-in-emacs-enabled ()
+ "Raise an error if `slime-enable-evaluate-in-emacs' isn't true."
+ (unless slime-enable-evaluate-in-emacs
+ (error "eval-in-emacs not enabled")))
+
;;;; `ED'
(defvar slime-ed-frame nil
"The frame used by `slime-ed'.")
-(defvar slime-ed-use-dedicated-frame t
- "*When non-nil, `slime-ed' will create and reuse a dedicated frame.")
+(defcustom slime-ed-use-dedicated-frame t
+ "*When non-nil, `slime-ed' will create and reuse a dedicated frame."
+ :type 'boolean
+ :group 'slime-mode)
(defun slime-ed (what)
"Edit WHAT.
@@ -5490,10 +6856,11 @@
WHAT can be:
A filename (string),
A list (FILENAME LINE [COLUMN]),
- A function name (symbol),
+ A list (FILENAME :charpos CHARPOS),
+ A function name (symbol or cons),
nil.
-This for use in the implementation of COMMON-LISP:ED."
+This is for use in the implementation of COMMON-LISP:ED."
;; Without `save-excursion' very strange things happen if you call
;; (swank:ed-in-emacs X) from the REPL. -luke (18/Jan/2004)
(save-excursion
@@ -5503,18 +6870,24 @@
(select-frame slime-ed-frame))
(cond ((stringp what)
(find-file (slime-from-lisp-filename what)))
- ((listp what)
+ ((and (consp what) (stringp (first what)))
(find-file (first (slime-from-lisp-filename what)))
- (goto-line (second what))
- ;; Find the correct column, without going past the end of
- ;; the line.
- (let ((col (third what)))
- (while (and col
- (< (point) (point-at-eol))
- (/= (decf col) -1))
- (forward-char 1))))
+ (cond
+ ((eql (second what) :charpos)
+ (goto-char (third what)))
+ (t
+ (goto-line (second what))
+ ;; Find the correct column, without going past the end of
+ ;; the line.
+ (let ((col (third what)))
+ (while (and col
+ (< (point) (point-at-eol))
+ (/= (decf col) -1))
+ (forward-char 1))))))
((and what (symbolp what))
(slime-edit-definition (symbol-name what)))
+ ((consp what)
+ (slime-edit-definition (prin1-to-string what)))
(t nil)))) ; nothing in particular
@@ -5545,19 +6918,20 @@
(destructuring-bind (output value) result
(insert output value)))))))
-(defun slime-eval-with-transcript (form &optional fn wait)
+(defun slime-eval-with-transcript (form &optional fn)
"Send FROM and PACKAGE to Lisp and pass the result to FN.
Display the result in the message area, if FN is nil.
Show the output buffer if the evaluation causes any output."
(with-current-buffer (slime-output-buffer)
- (slime-with-output-end-mark (slime-mark-output-start)))
+ (slime-with-output-end-mark
+ (slime-mark-output-start)))
(with-lexical-bindings (fn)
(slime-eval-async form
(lambda (value)
(with-current-buffer (slime-output-buffer)
+ (slime-show-last-output)
(cond (fn (funcall fn value))
- (t (message "%s" value)))
- (slime-show-last-output))))))
+ (t (message "%s" value))))))))
(defun slime-eval-describe (form)
"Evaluate FORM in Lisp and display the result in a new buffer."
@@ -5594,8 +6968,9 @@
window))))))
(defun slime-last-expression ()
- (buffer-substring-no-properties (save-excursion (backward-sexp) (point))
- (point)))
+ (slime-buffer-substring-with-reified-output
+ (save-excursion (backward-sexp) (point))
+ (point)))
(defun slime-eval-last-expression ()
"Evaluate the expression preceding point."
@@ -5649,6 +7024,21 @@
(insert "\n")
(slime-eval-print string))
+(defun slime-call-defun ()
+ (interactive)
+ "Insert a call to the function defined around point into the REPL."
+ (let ((toplevel (slime-parse-toplevel-form)))
+ (unless (and (consp toplevel)
+ (member (car toplevel) '(:defun :defmethod :defgeneric))
+ (symbolp (cadr toplevel)))
+ (error "Not in a function definition"))
+ (let* ((symbol (cadr toplevel))
+ (function-call
+ (format "(%s " (slime-qualify-cl-symbol-name symbol))))
+ (slime-switch-to-output-buffer)
+ (goto-char slime-repl-input-start-mark)
+ (insert function-call))))
+
;;;; Edit Lisp value
;;;
(defun slime-edit-value (form-string)
@@ -5711,7 +7101,7 @@
(defun slime-toggle-trace-fdefinition (&optional using-context-p)
"Toggle trace."
- (interactive "P")
+ (interactive "p")
(let ((spec (if using-context-p
(slime-extract-context)
(slime-symbol-at-point))))
@@ -5820,18 +7210,18 @@
"A helper function to determine the current context.
The pattern can have the form:
pattern ::= () ;matches always
- | (*) ;matches insde a list
+ | (*) ;matches inside a list
| (<symbol> <pattern>) ;matches if the first element in
- ; current the list is <symbol> and
+ ; the current list is <symbol> and
; if <pattern> matches.
- | ((<pattern>)) ;matches if are in a nested list."
+ | ((<pattern>)) ;matches if we are in a nested list."
(save-excursion
(let ((path (reverse (slime-pattern-path pattern))))
(loop for p in path
always (ignore-errors
(etypecase p
(symbol (slime-beginning-of-list)
- (looking-at (symbol-name p)))
+ (eq (read (current-buffer)) p))
(number (backward-up-list p)
t)))))))
@@ -5887,12 +7277,13 @@
(interactive (list
(read-file-name "Load file: " nil nil
nil (if (buffer-file-name)
- (file-name-sans-extension
- (file-name-nondirectory
- (buffer-file-name)))))))
+ (file-name-nondirectory
+ (buffer-file-name))))))
(let ((lisp-filename (slime-to-lisp-filename (expand-file-name filename))))
(slime-eval-with-transcript `(swank:load-file ,lisp-filename))))
+
+
;;;; Profiling
@@ -5944,20 +7335,26 @@
(defun slime-hyperspec-lookup (symbol-name)
"A wrapper for `hyperspec-lookup'"
- (interactive (list (let ((symbol-at-point (slime-symbol-name-at-point)))
- (if (and symbol-at-point
- (intern-soft (downcase symbol-at-point)
+ (interactive (list (let* ((symbol-at-point (slime-symbol-name-at-point))
+ (stripped-symbol
+ (and symbol-at-point
+ (downcase
+ (common-lisp-hyperspec-strip-cl-package
+ symbol-at-point)))))
+ (if (and stripped-symbol
+ (intern-soft stripped-symbol
common-lisp-hyperspec-symbols))
- symbol-at-point
+ stripped-symbol
(completing-read
"Look up symbol in Common Lisp HyperSpec: "
common-lisp-hyperspec-symbols #'boundp
- t symbol-at-point
+ t stripped-symbol
'common-lisp-hyperspec-history)))))
(hyperspec-lookup symbol-name))
(defun slime-show-description (string package)
- (slime-with-output-to-temp-buffer ("*SLIME Description*") package (princ string)))
+ (slime-with-output-to-temp-buffer ("*SLIME Description*")
+ package (princ string)))
(defun slime-describe-symbol (symbol-name)
"Describe the symbol at point."
@@ -6002,7 +7399,7 @@
(let ((buffer-package (or package (slime-current-package))))
(slime-eval-async
`(swank:apropos-list-for-emacs ,string ,only-external-p
- ,case-sensitive-p ,package)
+ ,case-sensitive-p ',package)
(lexical-let ((string string)
(package buffer-package)
(summary (slime-apropos-summary string case-sensitive-p
@@ -6025,7 +7422,7 @@
(defun slime-show-apropos (plists string package summary)
(if (null plists)
(message "No apropos matches for %S" string)
- (slime-with-output-to-temp-buffer ("*SLIME Apropos*" apropos-mode) package
+ (slime-with-output-to-temp-buffer ("*SLIME Apropos*" :mode apropos-mode) package
(set-syntax-table lisp-mode-syntax-table)
(slime-mode t)
(if (boundp 'header-line-format)
@@ -6060,6 +7457,8 @@
in '((:variable "Variable")
(:function "Function")
(:generic-function "Generic Function")
+ (:macro "Macro")
+ (:special-operator "Special Operator")
(:setf "Setf")
(:type "Type")
(:class "Class")
@@ -6067,6 +7466,7 @@
(:alien-struct "Alien struct")
(:alien-union "Alien type")
(:alien-enum "Alien enum"))
+ ;; Properties not listed here will not show up in the buffer
do
(let ((value (plist-get plist prop))
(start (point)))
@@ -6155,14 +7555,12 @@
(defmacro* slime-with-xref-buffer ((package ref-type symbol) &body body)
"Execute BODY in a xref buffer, then show that buffer."
- (let ((type (gensym))
- (sym (gensym)))
- `(let ((,type ,ref-type)
- (,sym ,symbol))
+ (let ((type (gensym)) (sym (gensym)) (pkg (gensym)))
+ `(let ((,type ,ref-type) (,sym ,symbol) (,pkg ,package))
(with-current-buffer (get-buffer-create
(format "*XREF[%s: %s]*" ,type ,sym))
(prog2 (progn
- (slime-init-xref-buffer ,package ,type ,sym)
+ (slime-init-xref-buffer ,pkg ,type ,sym)
(make-local-variable 'slime-xref-saved-window-configuration)
(setq slime-xref-saved-window-configuration
(current-window-configuration)))
@@ -6182,11 +7580,17 @@
(loop for (group . refs) in xrefs do
(progn
(slime-insert-propertized '(face bold) group "\n")
- (loop for (label . location) in refs do
- (slime-insert-propertized
+ (loop
+ for (label . location) in refs
+ do (slime-insert-propertized
(list 'slime-location location
'face 'font-lock-keyword-face)
- " " (slime-one-line-ify label) "\n"))))
+ " " (slime-one-line-ify label))
+ do (insert " - " (if (and (eql :location (car location))
+ (assoc :file (cdr location)))
+ (second (assoc :file (cdr location)))
+ "file unknown")
+ "\n"))))
;; Remove the final newline to prevent accidental window-scrolling
(backward-char 1)
(delete-char 1))
@@ -6325,14 +7729,80 @@
(let ((buffer (current-buffer)))
(delete-windows-on buffer)
(kill-buffer buffer)))
-
+
;;;; Macroexpansion
-(defun slime-eval-macroexpand (expander)
- (let ((string (slime-sexp-at-point)))
- (slime-eval-describe `(,expander ,string))))
+(define-minor-mode slime-macroexpansion-minor-mode
+ "SLIME mode for macroexpansion"
+ nil
+ " temp"
+ '(("q" . slime-temp-buffer-quit)
+ ("g" . slime-macroexpand-again)))
+(flet ((remap (from to)
+ (dolist (mapping (where-is-internal from slime-mode-map))
+ (define-key slime-macroexpansion-minor-mode-map mapping to))))
+ (remap 'slime-macroexpand-1 'slime-macroexpand-1-inplace)
+ (remap 'slime-macroexpand-all 'slime-macroexpand-all-inplace)
+ (remap 'undo '(lambda (&optional arg)
+ (interactive)
+ (let ((buffer-read-only nil))
+ (when slime-use-highlight-edits-mode
+ (slime-remove-edits (point-min) (point-max)))
+ (undo arg)))))
+
+(defvar slime-eval-macroexpand-expression nil
+ "Specifies the last macroexpansion preformed. This variable
+ specifies both what was expanded and how.")
+
+(defun slime-eval-macroexpand (expander &optional string)
+ (unless string
+ (setf string (slime-sexp-at-point-or-error)))
+ (setf slime-eval-macroexpand-expression `(,expander ,string))
+ (lexical-let ((package (slime-current-package)))
+ (slime-eval-async
+ slime-eval-macroexpand-expression
+ (lambda (expansion)
+ (slime-with-output-to-temp-buffer
+ ;; reusep for preserving `undo' functionality.
+ ("*SLIME macroexpansion*" :mode lisp-mode :reusep t) package
+ (slime-macroexpansion-minor-mode)
+ (erase-buffer)
+ (insert expansion)
+ (font-lock-fontify-buffer))))))
+
+(defun slime-eval-macroexpand-inplace (expander)
+ "Substitutes the current sexp at place with its macroexpansion.
+
+NB: Does not affect *slime-eval-macroexpand-expression*"
+ (interactive)
+ (lexical-let* ((string (slime-sexp-at-point-or-error))
+ (bounds (bounds-of-thing-at-point 'sexp))
+ (start (car bounds))
+ (end (cdr bounds))
+ (point (point))
+ (package (slime-current-package))
+ (buffer (current-buffer)))
+ ;; SLIME-SEXP-AT-POINT returns "'(FOO BAR BAZ)" even when point is
+ ;; placed at the opening parenthesis, which wouldn't get expanded
+ ;; even though FOO was a macro. Hence this workaround:
+ (when (and (eq ?\' (elt string 0)) (eq ?\( (elt string 1)))
+ (setf string (substring string 1)) (incf start))
+ (slime-eval-async
+ `(,expander ,string)
+ (lambda (expansion)
+ (with-current-buffer buffer
+ (let ((buffer-read-only nil))
+ (when slime-use-highlight-edits-mode
+ (slime-remove-edits (point-min) (point-max)))
+ (goto-char start)
+ (delete-region start end)
+ (insert expansion)
+ (goto-char start)
+ (indent-sexp)
+ (goto-char point)))))))
+
(defun slime-macroexpand-1 (&optional repeatedly)
"Display the macro expansion of the form at point. The form is
expanded with CL:MACROEXPAND-1 or, if a prefix argument is given, with
@@ -6341,18 +7811,45 @@
(slime-eval-macroexpand
(if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1)))
+(defun slime-macroexpand-1-inplace (&optional repeatedly)
+ (interactive "P")
+ (slime-eval-macroexpand-inplace
+ (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1)))
+
(defun slime-macroexpand-all ()
"Display the recursively macro expanded sexp at point."
(interactive)
(slime-eval-macroexpand 'swank:swank-macroexpand-all))
+(defun slime-macroexpand-all-inplace ()
+ "Display the recursively macro expanded sexp at point."
+ (interactive)
+ (slime-eval-macroexpand-inplace 'swank:swank-macroexpand-all))
+
+(defun slime-compiler-macroexpand ()
+ "Display the compiler-macro expansion of sexp at point."
+ (interactive)
+ (slime-eval-macroexpand 'swank:swank-compiler-macroexpand))
+
+(defun slime-compiler-macroexpand-1 ()
+ "Display the compiler-macro expansion of sexp at point."
+ (interactive)
+ (slime-eval-macroexpand 'swank:swank-compiler-macroexpand-1))
+
+(defun slime-macroexpand-again ()
+ "Reperform the last macroexpansion."
+ (interactive)
+ (slime-eval-macroexpand (first slime-eval-macroexpand-expression)
+ (second slime-eval-macroexpand-expression)))
+
;;;; Subprocess control
(defun slime-interrupt ()
"Interrupt Lisp."
(interactive)
- (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread)))
+ (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint))
+ (t (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread)))))
(defun slime-quit ()
(error "Not implemented properly. Use `slime-interrupt' instead."))
@@ -6362,6 +7859,7 @@
(interactive)
(slime-eval-async '(swank:quit-lisp))
(kill-buffer (slime-output-buffer))
+ (set-process-filter (slime-connection) nil)
(set-process-sentinel (slime-connection) 'slime-quit-sentinel))
(defun slime-quit-sentinel (process message)
@@ -6371,7 +7869,6 @@
(when inferior (delete-process inferior))
(when inferior-buffer (kill-buffer inferior-buffer))
(slime-net-close process)
- (slime-set-state "[not connected]" process)
(message "Connection closed.")))
(defun slime-set-package (package)
@@ -6380,7 +7877,7 @@
(message "*package*: %s" (slime-eval `(swank:set-package ,package))))
(defun slime-set-default-directory (directory)
- "Make DIRECTION become Lisp's current directory."
+ "Make DIRECTORY become Lisp's current directory."
(interactive (list (read-directory-name "Directory: " nil nil t)))
(message "default-directory: %s"
(slime-from-lisp-filename
@@ -6461,6 +7958,19 @@
;;;;; sldb-mode
+(defvar sldb-mode-syntax-table
+ (let ((table (copy-syntax-table lisp-mode-syntax-table)))
+ ;; We give < and > parenthesis syntax, so that #< ... > is treated
+ ;; as a balanced expression. This enables autodoc-mode to match
+ ;; #<unreadable> actual arguments in the backtraces with formal
+ ;; arguments of the function. (For Lisp mode, this is not
+ ;; desirable, since we do not wish to get a mismatched paren
+ ;; highlighted everytime we type < or >.)
+ (modify-syntax-entry ?< "(" table)
+ (modify-syntax-entry ?> ")" table)
+ table)
+ "Syntax table for SLDB mode.")
+
(define-derived-mode sldb-mode fundamental-mode "sldb"
"Superior lisp debugger mode. In addition to ordinary SLIME commands,
the following are available:\\<sldb-mode-map>
@@ -6497,12 +8007,13 @@
\\{sldb-mode-map}"
(erase-buffer)
- (set-syntax-table lisp-mode-syntax-table)
+ (set-syntax-table sldb-mode-syntax-table)
(slime-set-truncate-lines)
+ (when slime-use-autodoc-mode
+ (slime-autodoc-mode 1))
;; Make original slime-connection "sticky" for SLDB commands in this buffer
(setq slime-buffer-connection (slime-connection))
- (make-local-variable 'kill-buffer-hook)
- (add-hook 'kill-buffer-hook 'sldb-delete-overlays))
+ (add-local-hook 'kill-buffer-hook 'sldb-delete-overlays))
(defun sldb-help-summary ()
"Show summary of important sldb commands"
@@ -6550,6 +8061,8 @@
("R" 'sldb-return-from-frame)
("c" 'sldb-continue)
("s" 'sldb-step)
+ ("x" 'sldb-next)
+ ("o" 'sldb-out)
("b" 'sldb-break-on-return)
("a" 'sldb-abort)
("q" 'sldb-quit)
@@ -6662,12 +8175,13 @@
(recursive-edit)))))
(defun sldb-activate (thread level)
- (with-current-buffer (sldb-find-buffer thread)
- (unless (equal sldb-level level)
- (with-lexical-bindings (thread level)
- (slime-eval-async `(swank:debugger-info-for-emacs 0 1)
- (lambda (result)
- (apply #'sldb-setup thread level result)))))))
+ (unless (let ((b (sldb-find-buffer thread)))
+ (and b (with-current-buffer b (equal sldb-level level))))
+ (slime-rex (thread level)
+ ('(swank:debugger-info-for-emacs 0 10)
+ nil thread)
+ ((:ok result)
+ (apply #'sldb-setup thread level result)))))
(defun sldb-exit (thread level &optional stepping)
(when-let (sldb (sldb-find-buffer thread))
@@ -6682,6 +8196,9 @@
(defun sldb-insert-condition (condition)
(destructuring-bind (message type references extras) condition
+ (when (> (length message) 70)
+ (add-text-properties 0 (length message) (list 'help-echo message)
+ message))
(slime-insert-propertized '(sldb-default-action sldb-inspect-condition)
(in-sldb-face topline message)
"\n"
@@ -6928,9 +8445,9 @@
(let ((start (or start (point)))
(end (or end (save-excursion (ignore-errors (forward-sexp)) (point)))))
(push (make-overlay start (1+ start)) sldb-overlays)
- (push (make-overlay (1- end) end) sldb-overlays)
- (dolist (overlay sldb-overlays)
- (overlay-put overlay 'face 'secondary-selection))))
+ (push (make-overlay (1- end) end) sldb-overlays))
+ (dolist (overlay sldb-overlays)
+ (overlay-put overlay 'face 'secondary-selection)))
(defun sldb-toggle-details (&optional on)
@@ -6966,19 +8483,13 @@
(sldb-insert-locals frame-number indent2)
(when sldb-show-catch-tags
(let ((catchers (sldb-catch-tags frame-number)))
- (cond ((null catchers)
- (insert indent1
- (in-sldb-face catch-tag "[No catch-tags]\n")))
- (t
- (insert indent1 "Catch-tags:\n")
- (dolist (tag catchers)
- (slime-insert-propertized
- '(catch-tag ,tag)
- indent2 (in-sldb-face catch-tag
- (format "%s\n" tag))))))))
-
- (unless sldb-enable-styled-backtrace (terpri))
- (point)))))
+ (when catchers
+ (insert indent1 "Catch-tags:\n")
+ (dolist (tag catchers)
+ (slime-insert-propertized
+ '(catch-tag ,tag)
+ indent2
+ (in-sldb-face catch-tag (format "%s\n" tag)))))))))))
(apply #'sldb-maybe-recenter-region (sldb-frame-region)))
(defun sldb-frame-region ()
@@ -7015,7 +8526,7 @@
(let* ((number (sldb-frame-number-at-point)))
(slime-eval-async `(swank:eval-string-in-frame ,string ,number)
(if current-prefix-arg
- 'slime-output-string
+ 'slime-write-string
'slime-display-eval-result))))
(defun sldb-pprint-eval-in-frame (string)
@@ -7028,9 +8539,8 @@
(defun sldb-inspect-in-frame (string)
"Prompt for an expression and inspect it in the selected frame."
- (interactive (list (slime-read-from-minibuffer
- "Inspect in frame (evaluated): "
- (slime-sexp-at-point))))
+ (interactive (list (slime-read-object
+ "Inspect in frame (evaluated): ")))
(let ((number (sldb-frame-number-at-point)))
(slime-eval-async `(swank:inspect-in-frame ,string ,number)
'slime-open-inspector)))
@@ -7095,7 +8605,10 @@
(insert prefix (in-sldb-face local-name name))
(unless (zerop id)
(insert (in-sldb-face local-name (format "#%d" id))))
- (insert " = " (in-sldb-face local-value value)))
+ (insert " = ")
+ (slime-insert-presentation
+ (in-sldb-face local-value value)
+ `(:frame-var ,frame ,i)))
(insert "\n"))))
(defun sldb-inspect-var ()
@@ -7194,6 +8707,18 @@
(let ((frame (sldb-frame-number-at-point)))
(slime-eval-async `(swank:sldb-step ,frame))))
+(defun sldb-next ()
+ "Select the \"continue\" restart and set a new break point."
+ (interactive)
+ (let ((frame (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:sldb-next ,frame))))
+
+(defun sldb-out ()
+ "Select the \"continue\" restart and set a new break point."
+ (interactive)
+ (let ((frame (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:sldb-out ,frame))))
+
(defun sldb-break-on-return ()
"Set a breakpoint at the current frame.
The debugger is entered when the frame exits."
@@ -7242,7 +8767,7 @@
(interactive)
(when (null sldb-condition)
(error "No condition known (wrong buffer?)"))
- (slime-output-string (format "%s\n%s\n"
+ (slime-write-string (format "%s\n%s\n"
(first sldb-condition)
(second sldb-condition))))
@@ -7270,7 +8795,7 @@
(slime-propertize-region `(thread-id ,idx)
(insert (format "%3s: " id))
(slime-insert-propertized '(face bold) name)
- (insert-char ?\040 (- 30 (current-column)))
+ (insert-char ?\ (- 30 (current-column)))
(let ((summary-start (point)))
(insert " " summary)
(unless (bolp) (insert "\n"))
@@ -7296,6 +8821,7 @@
(defun slime-thread-quit ()
(interactive)
+ (slime-eval-async `(swank:quit-thread-browser))
(kill-buffer (current-buffer)))
(defun slime-thread-kill ()
@@ -7319,37 +8845,27 @@
;;;;; Connection listing
-(defvar slime-registered-lisp-implementations ())
+(defvar slime-lisp-implementations nil
+ "*A list of known Lisp implementations.
+The list should have the form:
+ ((NAME (PROGRAM PROGRAM-ARGS...) &key INIT CODING-SYSTEM) ...)
-(defun slime-register-lisp-implementation (name command)
- (interactive "sName: \nfCommand: ")
- (let ((cons (assoc name slime-registered-lisp-implementations)))
- (if cons
- (setf (cdr cons) command)
- (push (cons name command) slime-registered-lisp-implementations)))
- (if (string= inferior-lisp-program "lisp")
- (slime-select-lisp-implementation name)))
+NAME is a symbol for the implementation.
+PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process.
+INIT is a function that should return a string to load and start
+ Swank. The function will be called with the PORT-FILENAME and ENCODING as
+ arguments. INIT defaults to `slime-init-command'.
+CODING-SYSTEM a symbol for the coding system. The default is
+ slime-net-coding-system
-(defun slime-select-lisp-implementation (name)
- (interactive "sName: ")
- (setq inferior-lisp-program
- (cdr (assoc name slime-registered-lisp-implementations))))
+Here's an example:
+ ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init slime-init-command)
+ (acl (\"acl7\") :coding-system emacs-mule))")
-(defun slime-find-lisp-implementation (name)
- (let ((cons (or (assoc name slime-registered-lisp-implementations)
- (rassoc name slime-registered-lisp-implementations))))
- (if cons (cdr cons) name)))
+(defvar slime-default-lisp nil
+ "*The name of the default Lisp implementation.
+See `slime-lisp-implementations'")
-;; XXX: unused function
-(defun slime-find-lisp-implementation-name (command)
- (cdr (rassoc command slime-registered-lisp-implementations)))
-
-(defun slime-symbolic-lisp-name-p (name)
- (let ((cons (or (assoc name slime-registered-lisp-implementations)
- (rassoc name slime-registered-lisp-implementations))))
- (if cons (car cons))))
-
-
(define-derived-mode slime-connection-list-mode fundamental-mode
"connection-list"
"SLIME Connection List Mode.
@@ -7362,7 +8878,8 @@
((kbd "RET") 'slime-goto-connection)
("d" 'slime-connection-list-make-default)
("g" 'slime-update-connection-list)
- ((kbd "C-k") 'slime-quit-connection-at-point))
+ ((kbd "C-k") 'slime-quit-connection-at-point)
+ ("R" 'slime-restart-connection-at-point))
(defun slime-connection-at-point ()
(or (get-text-property (point) 'slime-connection)
@@ -7381,6 +8898,11 @@
(while (memq connection slime-net-processes)
(sit-for 0 100)))
(slime-update-connection-list))
+
+(defun slime-restart-connection-at-point (connection)
+ (interactive (list (slime-connection-at-point)))
+ (let ((slime-dispatching-connection connection))
+ (slime-restart-inferior-lisp)))
(defun slime-connection-list-make-default ()
"Make the connection at point the default connection."
@@ -7470,18 +8992,22 @@
(defvar slime-inspector-mark-stack '())
(defvar slime-saved-window-config)
-(defun slime-inspect (form)
+(defun slime-inspect (form &optional no-reset)
"Eval an expression and inspect the result."
(interactive (list (slime-read-object "Inspect value (evaluated): ")))
- (slime-eval-async form 'slime-open-inspector))
+ (slime-eval-async `(swank:init-inspector ,form ,(not no-reset))
+ 'slime-open-inspector))
(defun slime-read-object (prompt)
- (let ((id (get-text-property (point) 'slime-repl-old-output)))
- (if id
- `(swank:init-inspector ,(format "(swank:get-repl-result %S)" id))
- `(swank:init-inspector
- ,(slime-read-from-minibuffer "Inspect value (evaluated): "
- (slime-sexp-at-point))))))
+ "Read a Common Lisp expression from the minibuffer, providing
+defaults from the s-expression at point. If point is within a
+presentation, don't prompt, just return the presentation."
+ (multiple-value-bind (presentation start end)
+ (slime-presentation-around-point (point))
+ (if presentation
+ (slime-presentation-expression presentation)
+ (slime-read-from-minibuffer prompt
+ (slime-sexp-at-point)))))
(define-derived-mode slime-inspector-mode fundamental-mode "Slime-Inspector"
(set-syntax-table lisp-mode-syntax-table)
@@ -7505,12 +9031,16 @@
"Display INSPECTED-PARTS in a new inspector window.
Optionally set point to POINT."
(with-current-buffer (slime-inspector-buffer)
+ (setq slime-buffer-connection (slime-current-connection))
(let ((inhibit-read-only t))
(erase-buffer)
- (destructuring-bind (&key title type content) inspected-parts
+ (destructuring-bind (&key title type content id) inspected-parts
(macrolet ((fontify (face string)
- `(slime-inspector-fontify ,face ,string)))
- (insert (fontify topline title))
+ `(slime-inspector-fontify ,face ,string)))
+ (slime-propertize-region (list 'slime-part-number id
+ 'mouse-face 'highlight
+ 'face 'slime-inspector-action-face)
+ (slime-insert-presentation title `(:inspected-part ,id)))
(while (eq (char-before) ?\n)
(backward-delete-char 1))
(insert "\n [" (fontify label "type:") " " (fontify type type) "]\n"
@@ -7526,10 +9056,11 @@
(insert ispec)
(destructure-case ispec
((:value string id)
- (slime-insert-propertized (list 'slime-part-number id
- 'mouse-face 'highlight
- 'face 'slime-inspector-value-face)
- string))
+ (slime-propertize-region
+ (list 'slime-part-number id
+ 'mouse-face 'highlight
+ 'face 'slime-inspector-value-face)
+ (slime-insert-presentation string `(:inspected-part ,id))))
((:action string id)
(slime-insert-propertized (list 'slime-action-number id
'mouse-face 'highlight
@@ -7656,9 +9187,14 @@
(interactive)
(slime-eval-describe `(swank:describe-inspectee)))
+(defun slime-inspector-pprint (part)
+ (interactive (list (or (get-text-property (point) 'slime-part-number)
+ (error "No part at point"))))
+ (slime-eval-describe `(swank:pprint-inspector-part ,part)))
+
(defun slime-inspector-reinspect ()
(interactive)
- (slime-eval-async `(swank::inspect-object swank::*inspectee*) 'slime-open-inspector))
+ (slime-eval-async `(swank:inspector-reinspect) 'slime-open-inspector))
(slime-define-keys slime-inspector-mode-map
([return] 'slime-inspector-operate-on-point)
@@ -7669,6 +9205,7 @@
("n" 'slime-inspector-next)
(" " 'slime-inspector-next)
("d" 'slime-inspector-describe)
+ ("p" 'slime-inspector-pprint)
("q" 'slime-inspector-quit)
("g" 'slime-inspector-reinspect)
("\C-i" 'slime-inspector-next-inspectable-object)
@@ -7824,7 +9361,10 @@
(def-slime-selector-method ?r
"SLIME Read-Eval-Print-Loop."
- (slime-output-buffer))
+ (cond ((slime-current-connection)
+ (slime-output-buffer))
+ ((y-or-n-p "No connection: start Slime? ")
+ (slime))))
(def-slime-selector-method ?s
"*slime-scratch* buffer."
@@ -7870,6 +9410,7 @@
Only considers buffers that are not already visible."
(loop for buffer in (buffer-list)
when (and (with-current-buffer buffer (eq major-mode mode))
+ (not (string-match "^ " (buffer-name buffer)))
(null (get-buffer-window buffer 'visible)))
return buffer
finally (error "Can't find unshown buffer in %S" mode)))
@@ -7877,7 +9418,7 @@
;;;; Editing commands
-(defvar *slime-comment-start-regexp*
+(defvar slime-comment-start-regexp
"\\(\\(^\\|[^\n\\\\]\\)\\([\\\\][\\\\]\\)*\\);+[ \t]*"
"Regexp to match the start of a comment.")
@@ -7887,7 +9428,7 @@
Otherwise leave point unchanged and return NIL."
(let ((boundary (point)))
(beginning-of-line)
- (cond ((re-search-forward *slime-comment-start-regexp* boundary t)
+ (cond ((re-search-forward slime-comment-start-regexp boundary t)
(point))
(t (goto-char boundary)
nil))))
@@ -8070,11 +9611,17 @@
(string-match "^\\(def\\|\\with-\\)" symbol-name))
(let ((symbol (intern symbol-name))
(indent (cdr info)))
- ;; Does the symbol have an indentation value that we set?
- (when (equal (get symbol 'common-lisp-indent-function)
- (get symbol 'slime-indent))
- (put symbol 'slime-indent indent)
- (put symbol 'common-lisp-indent-function indent)))))))
+ (let ((old-slime-indent (get symbol 'slime-indent)))
+ (flet ((update (indent-function)
+ ;; Does the symbol have an indentation value
+ ;; that we set?
+ (when (equal (get symbol indent-function)
+ old-slime-indent)
+ (put symbol 'slime-indent indent)
+ (put symbol indent-function indent))))
+ (update 'common-lisp-indent-function)
+ (when (member 'scheme-mode slime-lisp-modes)
+ (update 'scheme-indent-function)))))))))
(defun slime-reindent-defun (&optional force-text-fill)
"Reindent the current defun, or refill the current paragraph.
@@ -8106,6 +9653,101 @@
(indent-region start end nil)))))
+;;;; Cheat Sheet
+
+(defun slime-cheat-sheet ()
+ (interactive)
+ (switch-to-buffer-other-frame (get-buffer-create "*SLIME Cheat Sheet*"))
+ (setq buffer-read-only nil)
+ (delete-region (point-min) (point-max))
+ (goto-char (point-min))
+ (insert "SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode).\n\n")
+ (dolist (mode slime-cheat-sheet-table)
+ (let ((title (getf mode :title))
+ (mode-map (getf mode :map))
+ (mode-keys (getf mode :bindings)))
+ (insert title)
+ (insert ":\n")
+ (insert (make-string (1+ (length title)) ?-))
+ (insert "\n")
+ (let ((keys '())
+ (descriptions '()))
+ (dolist (func mode-keys)
+ ;; func is eithor the function name or a list (NAME DESCRIPTION)
+ (push (if (symbolp func)
+ (prin1-to-string func)
+ (second func))
+ descriptions)
+ (let ((all-bindings (where-is-internal (if (symbolp func)
+ func
+ (first func))
+ (symbol-value mode-map)))
+ (key-bindings '()))
+ (dolist (binding all-bindings)
+ (when (and (vectorp binding)
+ (integerp (aref binding 0)))
+ (push binding key-bindings)))
+ (push (mapconcat 'key-description key-bindings " or ") keys)))
+ (loop
+ with key-length = (apply 'max (mapcar 'length keys))
+ with desc-length = (apply 'max (mapcar 'length descriptions))
+ for key in (nreverse keys)
+ for desc in (nreverse descriptions)
+ do (insert desc)
+ do (insert (make-string (- desc-length (length desc)) ? ))
+ do (insert " => ")
+ do (insert (if (string= "" key)
+ "<not on any key>"
+ key))
+ do (insert "\n")
+ finally do (insert "\n")))))
+ (setq buffer-read-only t)
+ (goto-char (point-min)))
+
+(defvar slime-cheat-sheet-table
+ '((:title "Editing lisp code"
+ :map slime-mode-map
+ :bindings ((slime-eval-defun "Evaluate current top level form")
+ (slime-compile-defun "Compile current top level form")
+ (slime-interactive-eval "Prompt for form and eval it")
+ (slime-compile-and-load-file "Compile and load current file")
+ (slime-sync-package-and-default-directory "Synch default package and directory with current buffer")
+ (slime-next-note "Next compiler note")
+ (slime-previous-note "Previous compiler note")
+ (slime-remove-notes "Remove notes")
+ slime-hyperspec-lookup))
+ (:title "Completion"
+ :map slime-mode-map
+ :bindings (slime-indent-and-complete-symbol
+ slime-fuzzy-complete-symbol))
+ (:title "At the REPL"
+ :map slime-repl-mode-map
+ :bindings (slime-repl-clear-buffer
+ slime-describe-symbol))
+ (:title "Within SLDB buffers"
+ :map sldb-mode-map
+ :bindings ((sldb-default-action "Do 'whatever' with thing at point")
+ (sldb-toggle-details "Toggle frame details visualization")
+ (sldb-quit "Quit to REPL")
+ (sldb-abort "Invoke ABORT restart")
+ (sldb-continue "Invoke CONTINUE restart (if available)")
+ (sldb-show-source "Jump to frame's source code")
+ (sldb-eval-in-frame "Evaluate in frame at point")
+ (sldb-inspect-in-frame "Evaluate in frame at point and inspect result")))
+ (:title "Within the Inspector"
+ :map slime-inspector-mode-map
+ :bindings ((slime-inspector-next-inspectable-object "Jump to next inspectable object")
+ (slime-inspector-operate-on-point "Inspect object or execute action at point")
+ (slime-inspector-reinspect "Reinspect current object")
+ (slime-inspector-pop "Return to previous object")
+ (slime-inspector-copy-down "Send object at point to REPL")
+ (slime-inspector-quit "Quit")))
+ (:title "Finding Definitions"
+ :map slime-mode-map
+ :bindings (slime-edit-definition
+ slime-pop-find-definition-stack))))
+
+
;;;; Test suite
(defstruct (slime-test (:conc-name slime-test.))
@@ -8155,8 +9797,22 @@
(goto-char (overlay-start o))
(show-subtree)))))
+(defun slime-run-one-test (name)
+ "Ask for the name of a test and then execute the test."
+ (interactive (list (slime-read-test-name)))
+ (let ((test (find name slime-tests :key #'slime-test.name)))
+ (assert test)
+ (let ((slime-tests (list test)))
+ (slime-run-tests))))
+
+(defun slime-read-test-name ()
+ (let ((alist (mapcar (lambda (test)
+ (list (symbol-name (slime-test.name test))))
+ slime-tests)))
+ (read (completing-read "Test: " alist nil t))))
+
(defun slime-test-should-fail-p (test)
- (member (slime-lisp-implementation-type-name)
+ (member (slime-lisp-implementation-name)
(slime-test.fails-for test)))
(defun slime-execute-tests ()
@@ -8173,6 +9829,7 @@
(slime-test-heading 1 "%s" name)
(dolist (input inputs)
(incf slime-total-tests)
+ (message "%s: %s" name input)
(slime-test-heading 2 "input: %s" input)
(if slime-test-debug-on-error
(let ((debug-on-error t)
@@ -8337,6 +9994,7 @@
(setq slime-tests nil)
(defun slime-check-top-level (&optional test-name)
+ (slime-accept-process-output nil 0.001)
(slime-check "At the top level (no debugging or pending RPCs)"
(slime-at-top-level-p)))
@@ -8350,7 +10008,10 @@
(cond ((time-less-p end (current-time))
(error "Timeout waiting for condition: %S" name))
(t
- (accept-process-output nil 0 100000))))))
+ ;; XXX if a process-filter enters a recursive-edit, we
+ ;; hang forever
+ (save-excursion
+ (slime-accept-process-output nil 0.1)))))))
(defun slime-sync-to-top-level (timeout)
(slime-wait-condition "top-level" #'slime-at-top-level-p timeout))
@@ -8433,7 +10094,7 @@
"Lookup the argument list for FUNCTION-NAME.
Confirm that EXPECTED-ARGLIST is displayed."
'(("swank:start-server"
- "(swank:start-server port-file &key \\((style \\*communication-style\\*)\\|style\\)[ \n]+dont-close[ \n]+(external-format \\*coding-system\\*))")
+ "(swank:start-server port-file &key \\((style swank:\\*communication-style\\*)\\|style\\)[ \n]+dont-close[ \n]+(external-format swank::\\*coding-system\\*))")
("swank::compound-prefix-match"
"(swank::compound-prefix-match prefix target)")
("swank::create-socket"
@@ -8477,13 +10138,25 @@
("(defun cl-user::foo ()
\"\\\" bla bla \\\"\"
(cl-user::bar))"
+ (cl-user::bar))
+ ("(defun cl-user::foo ()
+ #.*log-events*
+ (cl-user::bar))"
+ (cl-user::bar))
+ ("#.'(defun x () (/ 1 0))
+ (defun foo ()
+ (cl-user::bar))
+
+ "
(cl-user::bar)))
- (slime-check-top-level)
+ (slime-check-top-level)
(with-temp-buffer
(lisp-mode)
(insert program)
- (slime-compile-defun)
- (slime-sync)
+ (setq slime-buffer-package ":swank")
+ (slime-compile-string (buffer-string) 1)
+ (setq slime-buffer-package ":cl-user")
+ (slime-sync-to-top-level 5)
(goto-char (point-max))
(slime-previous-note)
(slime-check error-location-correct
@@ -8510,19 +10183,53 @@
(slime-eval-async 'no-such-variable)))))))
(let ((sldb-hook (cons debug-hook sldb-hook)))
(slime-eval-async 'no-such-variable)
- (slime-sync-to-top-level 15)
+ (slime-sync-to-top-level 5)
(slime-check-top-level)
(slime-check ("Maximum depth reached (%S) is %S."
debug-hook-max-depth depth)
(= debug-hook-max-depth depth))))))
+(def-slime-test unwind-to-previous-sldb-level (level2 level1)
+ "Test recursive debugging and returning to lower SLDB levels."
+ '((2 1) (4 2))
+ (slime-check-top-level)
+ (lexical-let ((level2 level2)
+ (level1 level1)
+ (state 'enter)
+ (max-depth 0))
+ (let ((debug-hook
+ (lambda ()
+ (with-current-buffer (sldb-get-default-buffer)
+ (setq max-depth (max sldb-level max-depth))
+ (ecase state
+ (enter
+ (cond ((= sldb-level level2)
+ (setq state 'leave)
+ (sldb-invoke-restart 0))
+ (t
+ (slime-eval-async `(cl:aref cl:nil ,sldb-level)))))
+ (leave
+ (cond ((= sldb-level level1)
+ (setq state 'ok)
+ (sldb-quit))
+ (t
+ (sldb-invoke-restart 0)))))))))
+ (let ((sldb-hook (cons debug-hook sldb-hook)))
+ (slime-eval-async `(cl:aref cl:nil 0))
+ (slime-sync-to-top-level 15)
+ (slime-check-top-level)
+ (slime-check ("Maximum depth reached (%S) is %S." max-depth level2)
+ (= max-depth level2))
+ (slime-check ("Final state reached.")
+ (eq state 'ok))))))
+
(def-slime-test loop-interrupt-quit
()
"Test interrupting a loop."
'(())
(slime-check-top-level)
(slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER")
- (accept-process-output nil 1)
+ (slime-accept-process-output nil 1)
(slime-check "In eval state." (slime-busy-p))
(slime-interrupt)
(slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5)
@@ -8562,29 +10269,30 @@
(let ((sldb-hook (lambda () (sldb-continue) (setq done t))))
(slime-interactive-eval
"(progn(cerror \"foo\" \"restart\")(cerror \"bar\" \"restart\")(+ 1 2))")
- (while (not done) (accept-process-output))
+ (while (not done) (slime-accept-process-output))
(slime-sync-to-top-level 5)
(slime-check-top-level)
(let ((message (current-message)))
(slime-check "Minibuffer contains: \"3\""
- (equal "3 (#x3, #o3, #b11)" message))))))
+ (equal "=> 3 (#x3, #o3, #b11)" message))))))
(def-slime-test interrupt-bubbling-idiot
()
"Test interrupting a loop that sends a lot of output to Emacs."
'(())
+ (slime-accept-process-output nil 1)
(slime-check-top-level)
(slime-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i)
- (cl:force-output)))
- (lambda (_) ) "CL-USER")
- (accept-process-output nil 1)
- (slime-wait-condition "running" #'slime-busy-p 5)
+ (cl:finish-output)))
+ (lambda (_) )
+ "CL-USER")
+ (sleep-for 1)
(slime-interrupt)
(slime-wait-condition "Debugger visible"
(lambda ()
(and (slime-sldb-level= 1)
(get-buffer-window (sldb-get-default-buffer))))
- 5)
+ 30)
(with-current-buffer (sldb-get-default-buffer)
(sldb-quit))
(slime-sync-to-top-level 5))
@@ -8599,11 +10307,10 @@
(let ((p (slime-eval
`(swank:listener-eval
,(format
- "(cl:setq cl:*package* (cl:find-package %S))
+ "(cl:setq cl:*print-case* :upcase)
+ (cl:setq cl:*package* (cl:find-package %S))
(cl:package-name cl:*package*)" package-name))
(slime-lisp-package))))
- (slime-check ("In %s package." package-name)
- (equal (format "\"%s\"" package-name) p))
(slime-check ("slime-lisp-package is %S." package-name)
(equal (slime-lisp-package) package-name))
(slime-check ("slime-lisp-package-prompt-string is in %S." nicknames)
@@ -8618,13 +10325,11 @@
("(princ 10)" "SWANK> (princ 10)
10
10
-SWANK> "
- )
+SWANK> ")
("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20)
1020
20
-SWANK> "
- )
+SWANK> ")
("(dotimes (i 10 77) (princ i) (terpri))"
"SWANK> (dotimes (i 10 77) (princ i) (terpri))
0
@@ -8638,9 +10343,7 @@
8
9
77
-SWANK> "
- )
- )
+SWANK> "))
(with-current-buffer (slime-output-buffer)
(setf (slime-lisp-package-prompt-string) "SWANK"))
(kill-buffer (slime-output-buffer))
@@ -8668,9 +10371,7 @@
("(+ 1\n" "2)" "SWANK> (+ 1
2)
3
-SWANK> ")
-
-)
+SWANK> "))
(with-current-buffer (slime-output-buffer)
(setf (slime-lisp-package-prompt-string) "SWANK"))
(kill-buffer (slime-output-buffer))
@@ -8701,8 +10402,8 @@
\(+ 2 3
4)
\(+ 2 3 4)
-SWANK> ")
- )
+SWANK> "))
+ (slime-sync-to-top-level 2)
(with-current-buffer (slime-output-buffer)
(setf (slime-lisp-package-prompt-string) "SWANK"))
(kill-buffer (slime-output-buffer))
@@ -8713,8 +10414,8 @@
(insert input)
(call-interactively 'slime-repl-return)
(slime-sync-to-top-level 5)
- (slime-check "Buffer contains result"
- (equal result-contents (buffer-string)))))
+ (slime-test-expect "Buffer contains result"
+ result-contents (buffer-string))))
(def-slime-test repl-read-lines
(command inputs final-contents)
@@ -8748,7 +10449,16 @@
SWANK> " nil)
("(princ 10)" ";;;; (princ 10) ...
10
+SWANK> " t)
+ ("(princ \"����������������������������\")"
+ ";;;; (princ \"����������������������������\") ...
+����������������������������
SWANK> " t))
+ (when (and (fboundp 'string-to-multibyte)
+ (with-current-buffer (process-buffer (slime-connection))
+ enable-multibyte-characters))
+ (setq input (funcall 'string-to-multibyte input))
+ (setq result-contents (funcall 'string-to-multibyte result-contents)))
(with-current-buffer (slime-output-buffer)
(setf (slime-lisp-package-prompt-string) "SWANK"))
(kill-buffer (slime-output-buffer))
@@ -8765,19 +10475,65 @@
()
"Test if BREAK invokes SLDB."
'(())
+ (slime-accept-process-output nil 1)
+ (slime-check-top-level)
(slime-compile-string (prin1-to-string '(cl:defun cl-user::foo ()
(cl:break)))
0)
+ (slime-sync-to-top-level 2)
(slime-eval-async '(cl-user::foo))
(slime-wait-condition "Debugger visible"
(lambda ()
(and (slime-sldb-level= 1)
(get-buffer-window (sldb-get-default-buffer))))
- 10)
+ 5)
(with-current-buffer (sldb-get-default-buffer)
(sldb-quit))
+ (slime-accept-process-output nil 1)
(slime-sync-to-top-level 5))
-
+
+(def-slime-test user-interrupt
+ ()
+ "Let's see what happens if we send a user interrupt at toplevel."
+ '(())
+ (slime-check-top-level)
+ (slime-interrupt)
+ (slime-wait-condition "Debugger visible"
+ (lambda ()
+ (and (slime-sldb-level= 1)
+ (get-buffer-window (sldb-get-default-buffer))))
+ 5)
+ (with-current-buffer (sldb-get-default-buffer)
+ (sldb-quit))
+ (slime-sync-to-top-level 5))
+
+(def-slime-test disconnect
+ ()
+ "Close the connetion.
+Confirm that the subprocess continues gracefully.
+Reconnect afterwards."
+ '(())
+ (slime-check-top-level)
+ (let* ((c (slime-connection))
+ (p (slime-inferior-process c)))
+ (with-current-buffer (process-buffer p)
+ (erase-buffer))
+ (delete-process c)
+ (assert (equal (process-status c) 'closed) nil "Connection not closed")
+ (slime-accept-process-output nil 0.1)
+ (assert (equal (process-status p) 'run) nil "Subprocess not running")
+ (with-current-buffer (process-buffer p)
+ (assert (< (buffer-size) 500) t "Unusual output"))
+ (slime-inferior-connect p (slime-inferior-lisp-args p))
+ (lexical-let ((hook nil))
+ (setq hook (lambda ()
+ (remove-hook 'slime-connected-hook hook)))
+ (add-hook 'slime-connected-hook hook)
+ (while (member hook slime-connected-hook)
+ (sit-for 0.5)
+ (slime-accept-process-output nil 0.1)))
+ (slime-test-expect "We are connected again" p (slime-inferior-process))))
+
;;;; Utilities
@@ -8819,7 +10575,11 @@
(if (slime-cl-symbol-package s)
s
(format "%s::%s"
- (slime-current-package)
+ (let* ((package (slime-current-package)))
+ ;; package is a string like ":cl-user" or "CL-USER".
+ (if (and package (string-match "^:" package))
+ (substring package 1)
+ package))
(slime-cl-symbol-name s)))))
@@ -8827,21 +10587,35 @@
(defun slime-defun-at-point ()
"Return the text of the defun at point."
+ (apply #'buffer-substring-no-properties
+ (slime-region-for-defun-at-point)))
+
+(defun slime-region-for-defun-at-point ()
+ "Return the start and end position of the toplevel form at point."
(save-excursion
(end-of-defun)
(let ((end (point)))
(beginning-of-defun)
- (buffer-substring-no-properties (point) end))))
+ (list (point) end))))
(defun slime-beginning-of-symbol ()
"Move point to the beginning of the current symbol."
- (and (minusp (skip-syntax-backward "w_"))
- (when (eq (char-before) ?#) ; special case for things like "#<foo"
- (forward-char))))
+ (when (slime-point-moves-p
+ (while (slime-point-moves-p
+ (skip-syntax-backward "w_")
+ (when (eq (char-before) ?|)
+ (backward-sexp)))))
+ (when (eq (char-before) ?#) ; special case for things like "#<foo"
+ (forward-char))))
(defun slime-end-of-symbol ()
"Move point to the end of the current symbol."
- (skip-syntax-forward "w_"))
+ (while (slime-point-moves-p
+ (skip-syntax-forward "w_")
+ ;; | has the syntax as ", so we need to
+ ;; treat it manually rather than via syntax.
+ (when (looking-at "|")
+ (forward-sexp)))))
(put 'slime-symbol 'end-op 'slime-end-of-symbol)
(put 'slime-symbol 'beginning-op 'slime-beginning-of-symbol)
@@ -8880,71 +10654,135 @@
(let ((string (thing-at-point 'sexp)))
(if string (substring-no-properties string) nil)))
-(defun slime-function-called-at-point/line ()
- "Return the name of the function being called at point, provided the
-function call starts on the same line at the point itself."
- (and (ignore-errors
- (slime-same-line-p (save-excursion (backward-up-list 1) (point))
- (point)))
- (slime-function-called-at-point)))
+(defun slime-sexp-at-point-or-error ()
+ "Return the sexp at point as a string, othwise signal an error."
+ (or (slime-sexp-at-point)
+ (error "No expression at point.")))
-(defun slime-function-called-at-point ()
- "Return a function around point or else called by the list containing point.
-Return the symbol-name, or nil."
- (ignore-errors
- (save-excursion
- (save-restriction
- (narrow-to-region (max (point-min) (- (point) 1000))
- (point-max))
- ;; Move up to surrounding paren, then after the open.
- (backward-up-list 1)
- (when (or (ignore-errors
- ;; "((foo" is probably not a function call
- (save-excursion (backward-up-list 1)
- (looking-at "(\\s *(")))
- ;; nor is "( foo"
- (looking-at "([ \t]"))
- (error "Probably not a Lisp function call"))
- (forward-char 1)
- (slime-symbol-name-at-point)))))
+(defun slime-parse-extended-operator-name (name)
+ "Assume that point is at the operator NAME in the
+current buffer. If NAME is MAKE-INSTANCE or another operator in
+`slime-extendeded-operator-name-parser-alist', collect additional
+information from the operator call and encode it as an extended
+operator name like (MAKE-INSTANCE CLASS \"make-instance\"). Return
+NAME or the extended operator name."
+ (save-excursion
+ (ignore-errors
+ (forward-char (1+ (length name)))
+ (slime-forward-blanks)
+ (let* ((symbol-name (upcase (slime-cl-symbol-name name)))
+ (assoc (assoc symbol-name slime-extended-operator-name-parser-alist)))
+ (when assoc
+ (setq name (funcall (cdr assoc) name))))))
+ name)
-(defun slime-enclosing-operator-names ()
- "Return the list of operator names of the forms containing point."
- (let ((result '()))
+(defvar slime-extended-operator-name-parser-alist
+ '(("MAKE-INSTANCE" . slime-parse-extended-operator-name/make-instance)
+ ("MAKE-CONDITION" . slime-parse-extended-operator-name/make-instance)
+ ("ERROR" . slime-parse-extended-operator-name/make-instance)
+ ("SIGNAL" . slime-parse-extended-operator-name/make-instance)
+ ("WARN" . slime-parse-extended-operator-name/make-instance)
+ ("CERROR" . slime-parse-extended-operator-name/cerror)
+ ("CHANGE-CLASS" . slime-parse-extended-operator-name/cerror)
+ ("DEFMETHOD" . slime-parse-extended-operator-name/defmethod)
+ ("APPLY" . slime-parse-extended-operator-name/apply)))
+
+(defun slime-parse-extended-operator-name/make-instance (name)
+ (let ((str (slime-sexp-at-point)))
+ (when (= (aref str 0) ?')
+ (setq name (list :make-instance (substring str 1)
+ name))))
+ name)
+
+(defun slime-parse-extended-operator-name/apply (name)
+ (let ((str (slime-sexp-at-point)))
+ (when (string-match "^#?'\\(.*\\)" str)
+ (setq name (list :make-instance (match-string 1 str)
+ name))))
+ name)
+
+(defun slime-parse-extended-operator-name/cerror (name)
+ (let ((continue-string-sexp (slime-sexp-at-point))
+ (class-sexp (progn (forward-sexp) (forward-char 1) (slime-sexp-at-point))))
+ (when (= (aref class-sexp 0) ?')
+ (setq name (list :make-instance (substring class-sexp 1)
+ name
+ continue-string-sexp))))
+ name)
+
+(defun slime-parse-extended-operator-name/defmethod (name)
+ (let ((str (slime-sexp-at-point)))
+ (setq name (list :defmethod str))))
+
+(defun slime-enclosing-operator-names (&optional max-levels)
+ "Return the list of operator names of the forms containing point.
+As a secondary value, return the indices of the respective argument to
+the operator. When MAX-LEVELS is non-nil, go up at most this many
+levels of parens."
+ (let ((result '())
+ (arg-indices '())
+ (level 1))
(ignore-errors
- (save-restriction
- (narrow-to-region (save-excursion (beginning-of-defun) (point))
- (point))
- (save-excursion
- (while t
- (backward-up-list 1)
- (when (looking-at "(")
- (forward-char 1)
- (when-let (name (slime-symbol-name-at-point))
- (push name result))
- (backward-up-list 1))))))
- (nreverse result)))
+ (save-excursion
+ ;; Make sure we get the whole operator name.
+ (slime-end-of-symbol)
+ (save-restriction
+ (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)) '(?\ ?>)))
+ (incf arg-index))
+ (ignore-errors
+ (backward-sexp 1))
+ (while (ignore-errors (backward-sexp 1)
+ (> (point) (point-min)))
+ (incf arg-index))
+ (backward-up-list 1)
+ (when (member (char-syntax (char-after)) '(?\( ?'))
+ (incf level)
+ (forward-char 1)
+ (let ((name (slime-symbol-name-at-point)))
+ (cond
+ (name
+ (push (slime-parse-extended-operator-name name) result)
+ (push arg-index arg-indices))
+ (t
+ (push nil result)
+ (push arg-index arg-indices))))
+ (backward-up-list 1)))))))
+ (values
+ (nreverse result)
+ (nreverse arg-indices))))
;;;;; Portability library
(when (featurep 'xemacs)
- (require 'overlay)
- (defun next-single-char-property-change (&rest args)
- (or (apply 'next-single-property-change args)
- (point-max)))
- (defun previous-single-char-property-change (&rest args)
- (or (apply 'previous-single-property-change args)
- (point-min)))
- (unless (fboundp 'string-make-unibyte)
- (defalias 'string-make-unibyte #'identity))
- )
+ (require 'overlay))
(eval-when (compile eval)
(defmacro slime-defun-if-undefined (name &rest rest)
`(unless (fboundp ',name)
(defun ,name ,@rest))))
+(defvar slime-accept-process-output-supports-floats
+ (ignore-errors (accept-process-output nil 0.0) t))
+
+(defun slime-accept-process-output (&optional process timeout)
+ "Like `accept-process-output' but the TIMEOUT argument can be a float."
+ (cond (slime-accept-process-output-supports-floats
+ (accept-process-output process timeout))
+ (t
+ (accept-process-output process
+ (if timeout (truncate timeout))
+ ;; Emacs 21 uses microsecs; Emacs 22 millisecs
+ (if timeout (truncate (* timeout 1000000)))))))
+
(put 'slime-defun-if-undefined 'lisp-indent-function 2)
(slime-defun-if-undefined next-single-char-property-change
@@ -8989,11 +10827,24 @@
(get-char-property (1- pos) prop object)))
return pos))))))))
+(slime-defun-if-undefined next-char-property-change (position &optional limit)
+ (let ((tmp (next-overlay-change position)))
+ (when tmp
+ (setq tmp (min tmp limit)))
+ (next-property-change position nil tmp)))
+
+(slime-defun-if-undefined previous-char-property-change
+ (position &optional limit)
+ (let ((tmp (previous-overlay-change position)))
+ (when tmp
+ (setq tmp (max tmp limit)))
+ (previous-property-change position nil tmp)))
+
(slime-defun-if-undefined substring-no-properties (string &optional start end)
(let* ((start (or start 0))
(end (or end (length string)))
(string (substring string start end)))
- (set-text-properties start end nil string)
+ (set-text-properties 0 (- end start) nil string)
string))
(slime-defun-if-undefined set-window-text-height (window height)
@@ -9160,6 +11011,21 @@
(or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp"))))
"The directory for writing temporary files."))
+(unless (fboundp 'with-temp-message)
+ (defmacro with-temp-message (message &rest body)
+ (let ((current-message (make-symbol "current-message"))
+ (temp-message (make-symbol "with-temp-message")))
+ `(let ((,temp-message ,message)
+ (,current-message))
+ (unwind-protect
+ (progn
+ (when ,temp-message
+ (setq ,current-message (current-message))
+ (message "%s" ,temp-message))
+ ,@body)
+ (and ,temp-message ,current-message
+ (message "%s" ,current-message)))))))
+
(defun slime-emacs-20-p ()
(and (not (featurep 'xemacs))
(= emacs-major-version 20)))
@@ -9184,8 +11050,9 @@
'(slime-alistify
slime-log-event
slime-events-buffer
- slime-output-string
+ slime-write-string
slime-output-buffer
+ slime-connection-output-buffer
slime-output-filter
slime-repl-show-maximum-output
slime-process-available-input
@@ -9203,4 +11070,10 @@
(provide 'slime)
+;; Local Variables:
+;; outline-regexp: ";;;;+"
+;; indent-tabs-mode: nil
+;; coding: latin-1-unix
+;; unibyte: t
+;; End:
;;; slime.el ends here
Modified: trunk/thirdparty/emacs/slime/swank-abcl.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-abcl.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-abcl.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,4 +1,4 @@
-;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
+;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
;;;
;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
;;;
@@ -17,7 +17,7 @@
(defun sys::break (&optional (format-control "BREAK called")
&rest format-arguments)
- (let ((*saved-backtrace* (sys::backtrace-as-list)))
+ (let ((*saved-backtrace* (backtrace-as-list-ignoring-swank-calls)))
(with-simple-restart (continue "Return from BREAK.")
(invoke-debugger
(sys::%make-condition 'simple-condition
@@ -25,26 +25,46 @@
:format-arguments format-arguments))))
nil))
-
(defimplementation make-fn-streams (input-fn output-fn)
(let* ((output (ext:make-slime-output-stream output-fn))
(input (ext:make-slime-input-stream input-fn output)))
(values input output)))
+(defimplementation call-with-compilation-hooks (function)
+ (funcall function))
+
;;; swank-mop
-;;dummies:
+;;dummies and definition
(defclass standard-slot-definition ()())
-(defun class-finalized-p (class) t)
+;(defun class-finalized-p (class) t)
(defun slot-definition-documentation (slot) #+nil (documentation slot 't))
(defun slot-definition-type (slot) t)
(defun class-prototype (class))
(defun generic-function-declarations (gf))
-(defun specializer-direct-methods (spec) nil)
+(defun specializer-direct-methods (spec) (mop::class-direct-methods spec))
+(defun slot-definition-name (slot)
+ (mop::%slot-definition-name slot))
+
+(defun class-slots (class)
+ (mop::%class-slots class))
+
+(defun method-generic-function (method)
+ (mop::%method-generic-function method))
+
+(defun method-function (method)
+ (mop::%method-function method))
+
+(defun slot-boundp-using-class (class object slotdef)
+ (system::slot-boundp object (slot-definition-name slotdef)))
+
+(defun slot-value-using-class (class object slotdef)
+ (system::slot-value object (slot-definition-name slotdef)))
+
(import-to-swank-mop
'( ;; classes
cl:standard-generic-function
@@ -58,12 +78,12 @@
mop::class-direct-subclasses
mop::class-direct-superclasses
mop::eql-specializer
- class-finalized-p ;;dummy
+ mop::class-finalized-p
cl:class-name
mop::class-precedence-list
class-prototype ;;dummy
- mop::class-slots
- specializer-direct-methods ;;dummy
+ class-slots
+ specializer-direct-methods
;; eql-specializer accessors
mop::eql-specializer-object
;; generic function readers
@@ -75,8 +95,8 @@
mop::generic-function-method-combination
mop::generic-function-name
;; method readers
- mop::method-generic-function
- mop::method-function
+ method-generic-function
+ method-function
mop::method-lambda-list
mop::method-specializers
mop::method-qualifiers
@@ -86,10 +106,13 @@
mop::slot-definition-initargs
mop::slot-definition-initform
mop::slot-definition-initfunction
- mop::slot-definition-name
+ slot-definition-name
slot-definition-type ;;dummy
mop::slot-definition-readers
- mop::slot-definition-writers))
+ mop::slot-definition-writers
+ slot-boundp-using-class
+ slot-value-using-class
+ ))
;;;; TCP Server
@@ -111,8 +134,8 @@
(ext:server-socket-close socket))
(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix))
- (assert (eq external-format :iso-latin-1-unix))
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout external-format))
(ext:get-socket-stream (ext:socket-accept socket)))
;;;; Unix signals
@@ -135,13 +158,12 @@
;;;; Misc
+(defimplementation arglist (fun)
+ (cond ((symbolp fun)
+ (multiple-value-bind (arglist present) (sys::arglist fun)
+ (if present arglist :not-available)))
+ (t :not-available)))
-(defimplementation arglist ((symbol t))
- (multiple-value-bind (arglist present)
- (sys::arglist symbol)
- (if present arglist :not-available)))
-
-
(defimplementation function-name (function)
(nth-value 2 (function-lambda-expression function)))
@@ -190,16 +212,20 @@
(defvar *sldb-topframe*)
+(defun backtrace-as-list-ignoring-swank-calls ()
+ (let ((list (ext:backtrace-as-list)))
+ (subseq list (1+ (or (position (intern "SWANK-DEBUGGER-HOOK" 'swank) list :key 'car) -1)))))
+
(defimplementation call-with-debugging-environment (debugger-loop-fn)
- (let ((*sldb-topframe* (car (ext:backtrace-as-list)) #+nil (excl::int-newest-frame)))
+ (let ((*sldb-topframe* (car (backtrace-as-list-ignoring-swank-calls)) #+nil (excl::int-newest-frame)))
(funcall debugger-loop-fn)))
(defun nth-frame (index)
- (nth index (ext:backtrace-as-list)))
+ (nth index (backtrace-as-list-ignoring-swank-calls)))
(defimplementation compute-backtrace (start end)
(let ((end (or end most-positive-fixnum)))
- (subseq (ext:backtrace-as-list) start end)))
+ (subseq (backtrace-as-list-ignoring-swank-calls) start end)))
(defimplementation print-frame (frame stream)
(write-string (string-trim '(#\space #\newline)
@@ -207,7 +233,7 @@
stream))
(defimplementation frame-locals (index)
- `((list :name "??" :id 0 :value "??")))
+ `(,(list :name "??" :id 0 :value "??")))
(defimplementation frame-catch-tags (index)
@@ -249,43 +275,54 @@
(defvar *buffer-string*)
(defvar *compile-filename*)
+(in-package :swank-backend)
+
(defun handle-compiler-warning (condition)
- #+nil
- (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
- (signal (make-condition
- 'compiler-condition
- :original-condition condition
- :severity :warning
- :message (format nil "~A" condition)
- :location (cond (*buffer-name*
- (make-location
- (list :buffer *buffer-name*)
- (list :position *buffer-start-position*)))
- (loc
- (destructuring-bind (file . pos) loc
+ (let ((loc nil));(getf (slot-value condition 'excl::plist) :loc)))
+ (unless (member condition *abcl-signaled-conditions*) ; filter condition signaled more than once.
+ (push condition *abcl-signaled-conditions*)
+ (signal (make-condition
+ 'compiler-condition
+ :original-condition condition
+ :severity :warning
+ :message (format nil "~A" condition)
+ :location (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (list :position *buffer-start-position*)))
+ (loc
+ (destructuring-bind (file . pos) loc
+ (make-location
+ (list :file (namestring (truename file)))
+ (list :position (1+ pos)))))
+ (t
(make-location
- (list :file (namestring (truename file)))
- (list :position (1+ pos)))))
- (t
- (make-location
- (list :file *compile-filename*)
- (list :position 1))))))))
+ (list :file *compile-filename*)
+ (list :position 1)))))))))
-(defimplementation swank-compile-file (*compile-filename* load-p)
- (handler-bind ((warning #'handle-compiler-warning))
- (let ((*buffer-name* nil))
- (multiple-value-bind (fn warn fail)
- (compile-file *compile-filename*)
- (when load-p (unless fail (load fn)))))))
+(defvar *abcl-signaled-conditions*)
+(defimplementation swank-compile-file (filename load-p external-format)
+ (declare (ignore external-format))
+ (let ((jvm::*resignal-compiler-warnings* t)
+ (*abcl-signaled-conditions* nil))
+ (handler-bind ((warning #'handle-compiler-warning))
+ (let ((*buffer-name* nil)
+ (*compile-filename* filename))
+ (multiple-value-bind (fn warn fail) (compile-file filename)
+ (when (and load-p (not fail))
+ (load fn)))))))
+
(defimplementation swank-compile-string (string &key buffer position directory)
(declare (ignore directory))
- (handler-bind ((warning #'handle-compiler-warning))
- (let ((*buffer-name* buffer)
- (*buffer-start-position* position)
- (*buffer-string* string))
- (funcall (compile nil (read-from-string
- (format nil "(~S () ~A)" 'lambda string)))))))
+ (let ((jvm::*resignal-compiler-warnings* t)
+ (*abcl-signaled-conditions* nil))
+ (handler-bind ((warning #'handle-compiler-warning))
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-string* string))
+ (funcall (compile nil (read-from-string
+ (format nil "(~S () ~A)" 'lambda string))))))))
#|
;;;; Definition Finding
@@ -364,17 +401,17 @@
(defmethod inspect-for-emacs ((slot mop::slot-definition) (inspector abcl-inspector))
(declare (ignore inspector))
(values "A slot."
- `("Name: " (:value ,(mop::slot-definition-name slot))
+ `("Name: " (:value ,(mop::%slot-definition-name slot))
(:newline)
"Documentation:" (:newline)
,@(when (slot-definition-documentation slot)
`((:value ,(slot-definition-documentation slot)) (:newline)))
"Initialization:" (:newline)
- " Args: " (:value ,(mop::slot-definition-initargs slot)) (:newline)
- " Form: " ,(if (mop::slot-definition-initfunction slot)
- `(:value ,(mop::slot-definition-initform slot))
+ " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
+ " Form: " ,(if (mop::%slot-definition-initfunction slot)
+ `(:value ,(mop::%slot-definition-initform slot))
"#<unspecified>") (:newline)
- " Function: " (:value ,(mop::slot-definition-initfunction slot))
+ " Function: " (:value ,(mop::%slot-definition-initfunction slot))
(:newline))))
(defmethod inspect-for-emacs ((f function) (inspector abcl-inspector))
@@ -395,7 +432,7 @@
#|
-(defimplementation inspect-for-emacs ((o t) (inspector abcl-inspector))
+(defmethod inspect-for-emacs ((o t) (inspector abcl-inspector))
(let* ((class (class-of o))
(slots (mop::class-slots class)))
(values (format nil "~A~% is a ~A" o class)
@@ -469,6 +506,33 @@
(defimplementation receive ()
(ext:mailbox-read (mailbox (ext:current-thread))))
+;;; Auto-flush streams
+
+;; XXX race conditions
+(defvar *auto-flush-streams* '())
+
+(defvar *auto-flush-thread* nil)
+
+(defimplementation make-stream-interactive (stream)
+ (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
+ (unless *auto-flush-thread*
+ (setq *auto-flush-thread*
+ (ext:make-thread #'flush-streams
+ :name "auto-flush-thread"))))
+
+(defun flush-streams ()
+ (loop
+ (setq *auto-flush-streams*
+ (remove-if (lambda (x)
+ (not (and (open-stream-p x)
+ (output-stream-p x))))
+ *auto-flush-streams*))
+ (mapc #'finish-output *auto-flush-streams*)
+ (sleep 0.15)))
+
(defimplementation quit-lisp ()
(ext:exit))
+
+
+
Modified: trunk/thirdparty/emacs/slime/swank-allegro.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-allegro.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-allegro.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,41 +1,29 @@
-;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
+;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
;;;
;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
;;;
;;; Created 2003
;;;
;;; This code has been placed in the Public Domain. All warranties
-;;; are disclaimed. This code was written for "Allegro CL Trial
-;;; Edition "5.0 [Linux/X86] (8/29/98 10:57)".
+;;; are disclaimed.
;;;
(in-package :swank-backend)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :sock)
- (require :process)
+ (require :process))
- (import
- '(excl:fundamental-character-output-stream
- excl:stream-write-char
- excl:stream-force-output
- excl:fundamental-character-input-stream
- excl:stream-read-char
- excl:stream-listen
- excl:stream-unread-char
- excl:stream-clear-input
- excl:stream-line-column
- excl:stream-read-char-no-hang)))
+(import-from :excl *gray-stream-symbols* :swank-backend)
;;; swank-mop
-;; maybe better change MOP to ACLMOP ?
-;; CLOS also works in ACL5. --he
(import-swank-mop-symbols :clos '(:slot-definition-documentation))
(defun swank-mop:slot-definition-documentation (slot)
(documentation slot t))
+
;;;; TCP Server
(defimplementation preferred-communication-style ()
@@ -51,22 +39,30 @@
(defimplementation close-socket (socket)
(close socket))
-(defimplementation accept-connection (socket &key external-format)
- (let ((ef (or external-format :iso-latin-1-unix))
- (s (socket:accept-connection socket :wait t)))
- (set-external-format s ef)
+(defimplementation accept-connection (socket &key external-format buffering
+ timeout)
+ (declare (ignore buffering timeout))
+ (let ((s (socket:accept-connection socket :wait t)))
+ (when external-format
+ (setf (stream-external-format s) external-format))
s))
-(defun set-external-format (stream external-format)
- #-allegro-v5.0
- (let* ((name (ecase external-format
- (:iso-latin-1-unix :latin1)
- (:utf-8-unix :utf-8-unix)
- (:emacs-mule-unix :emacs-mule)))
- (ef (excl:crlf-base-ef
- (excl:find-external-format name :try-variant t))))
- (setf (stream-external-format stream) ef)))
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")
+ (:euc-jp "euc-jp" "euc-jp-unix")
+ (:us-ascii "us-ascii" "us-ascii-unix")
+ (:emacs-mule "emacs-mule" "emacs-mule-unix")))
+(defimplementation find-external-format (coding-system)
+ (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+ (and e (excl:crlf-base-ef
+ (excl:find-external-format (car e)
+ :try-variant t)))))
+
(defimplementation format-sldb-condition (c)
(princ-to-string c))
@@ -89,9 +85,8 @@
"allegro")
(defimplementation set-default-directory (directory)
- (let ((dir (namestring (setf *default-pathname-defaults*
- (truename (merge-pathnames directory))))))
- (excl:chdir dir)
+ (let* ((dir (namestring (truename (merge-pathnames directory)))))
+ (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
dir))
(defimplementation default-directory ()
@@ -145,6 +140,15 @@
(excl::*break-hook* nil))
(funcall debugger-loop-fn)))
+(defimplementation sldb-break-at-start (fname)
+ ;; :print-before is kind of mis-used but we just want to stuff our break form
+ ;; somewhere. This does not work for setf, :before and :after methods, which
+ ;; need special syntax in the trace call, see ACL's doc/debugging.htm chapter 10.
+ (eval `(trace (,fname
+ :print-before
+ ((break "Function start breakpoint of ~A" ',fname)))))
+ `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
+
(defun find-topframe ()
(let ((skip-frames 3))
(do ((f (excl::int-newest-frame) (next-frame f))
@@ -232,7 +236,6 @@
(member (type-of object) '(excl::compiler-note compiler::compiler-note)))
(defun compiler-undefined-functions-called-warning-p (object)
- #-allegro-v5.0
(typep object 'excl:compiler-undefined-functions-called-warning))
(deftype compiler-note ()
@@ -287,10 +290,12 @@
)
(funcall function)))
-(defimplementation swank-compile-file (*compile-filename* load-p)
+(defimplementation swank-compile-file (filename load-p external-format)
(with-compilation-hooks ()
- (let ((*buffer-name* nil))
- (compile-file *compile-filename* :load-after-compile load-p))))
+ (let ((*buffer-name* nil)
+ (*compile-filename* filename))
+ (compile-file *compile-filename* :load-after-compile load-p
+ :external-format external-format))))
(defun call-with-temp-file (fn)
(let ((tmpname (system:make-temp-file-name)))
@@ -304,7 +309,12 @@
(lambda (stream filename)
(write-string string stream)
(finish-output stream)
- (let ((binary-filename (compile-file filename :load-after-compile t)))
+ (let ((binary-filename
+ (excl:without-redefinition-warnings
+ ;; Suppress Allegro's redefinition warnings; they are
+ ;; pointless when we are compiling via a temporary
+ ;; file.
+ (compile-file filename :load-after-compile t))))
(when binary-filename
(delete-file binary-filename))))))
@@ -350,10 +360,17 @@
(when (<= pos 0)
(return cr-count))))))
-(defun find-definition-in-file (fspec type file)
- (let* ((start (or (scm:find-definition-in-file fspec type file)
- (scm:find-definition-in-file (fspec-primary-name fspec)
- type file)))
+(defun find-definition-in-file (fspec type file top-level)
+ (let* ((part
+ (or (scm::find-definition-in-definition-group
+ fspec type (scm:section-file :file file)
+ :top-level top-level)
+ (scm::find-definition-in-definition-group
+ (fspec-primary-name fspec)
+ type (scm:section-file :file file)
+ :top-level top-level)))
+ (start (and part
+ (scm::source-part-start part)))
(pos (if start
(list :position (1+ (- start (count-cr file start))))
(list :function-name (string (fspec-primary-name fspec))))))
@@ -366,29 +383,15 @@
(list :buffer (subseq filename 0 pos))
(list :position (parse-integer (subseq filename (1+ pos)))))))
-(defun find-fspec-location (fspec type)
- (multiple-value-bind (file err) (ignore-errors (excl:source-file fspec type))
- (etypecase file
- (pathname
- (find-definition-in-file fspec type file))
- ((member :top-level)
- (list :error (format nil "Defined at toplevel: ~A"
- (fspec->string fspec))))
- (string
- (find-definition-in-buffer file))
- (null
- (list :error (if err
- (princ-to-string err)
- (format nil "Unknown source location for ~A"
- (fspec->string fspec)))))
- (cons
- (destructuring-bind ((type . filename)) file
- (assert (member type '(:operator)))
- (etypecase filename
- (pathname
- (find-definition-in-file fspec type filename))
- (string
- (find-definition-in-buffer filename))))))))
+(defun find-fspec-location (fspec type file top-level)
+ (etypecase file
+ (pathname
+ (find-definition-in-file fspec type file top-level))
+ ((member :top-level)
+ (list :error (format nil "Defined at toplevel: ~A"
+ (fspec->string fspec))))
+ (string
+ (find-definition-in-buffer file))))
(defun fspec->string (fspec)
(etypecase fspec
@@ -400,10 +403,28 @@
(prin1-to-string (second fspec)))))))
(defun fspec-definition-locations (fspec)
- (let ((defs (excl::find-multiple-definitions fspec)))
- (loop for (fspec type) in defs
- collect (list (list type fspec)
- (find-fspec-location fspec type)))))
+ (cond
+ ((and (listp fspec)
+ (eql (car fspec) :top-level-form))
+ (destructuring-bind (top-level-form file position) fspec
+ (list
+ (list (list nil fspec)
+ (make-location (list :buffer file)
+ (list :position position t))))))
+ ((and (listp fspec) (eq (car fspec) :internal))
+ (destructuring-bind (_internal next _n) fspec
+ (fspec-definition-locations next)))
+ (t
+ (let ((defs (excl::find-source-file fspec)))
+ (if (null defs)
+ (list
+ (list (list nil fspec)
+ (list :error
+ (format nil "Unknown source location for ~A"
+ (fspec->string fspec)))))
+ (loop for (fspec type file top-level) in defs
+ collect (list (list type fspec)
+ (find-fspec-location fspec type file top-level))))))))
(defimplementation find-definitions (symbol)
(fspec-definition-locations symbol))
@@ -471,6 +492,80 @@
2)
(xref-result result)))
+;;;; Profiling
+
+;; Per-function profiling based on description in
+;; http://www.franz.com/support/documentation/8.0/doc/runtime-analyzer.htm#dat…
+
+(defvar *profiled-functions* ())
+(defvar *profile-depth* 0)
+
+(defmacro with-redirected-y-or-n-p (&body body)
+ ;; If the profiler is restarted when the data from the previous
+ ;; session is not reported yet, the user is warned via Y-OR-N-P.
+ ;; As the CL:Y-OR-N-P question is (for some reason) not directly
+ ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
+ ;; overruled.
+ `(let* ((pkg (find-package "common-lisp"))
+ (saved-pdl (excl::package-definition-lock pkg))
+ (saved-ynp (symbol-function 'cl:y-or-n-p)))
+
+ (setf (excl::package-definition-lock pkg) nil
+ (symbol-function 'cl:y-or-n-p) (symbol-function
+ (find-symbol "y-or-n-p-in-emacs"
+ "swank")))
+ (unwind-protect
+ (progn ,@body)
+
+ (setf (symbol-function 'cl:y-or-n-p) saved-ynp
+ (excl::package-definition-lock pkg) saved-pdl))))
+
+(defun start-acl-profiler ()
+ (with-redirected-y-or-n-p
+ (prof:start-profiler :type :time :count t
+ :start-sampling-p nil :verbose nil)))
+(defun acl-profiler-active-p ()
+ (not (eq (prof:profiler-status :verbose nil) :inactive)))
+
+(defun stop-acl-profiler ()
+ (prof:stop-profiler :verbose nil))
+
+(excl:def-fwrapper profile-fwrapper (&rest args)
+ ;; Ensures sampling is done during the execution of the function,
+ ;; taking into account recursion.
+ (declare (ignore args))
+ (cond ((zerop *profile-depth*)
+ (let ((*profile-depth* (1+ *profile-depth*)))
+ (prof:start-sampling)
+ (unwind-protect (excl:call-next-fwrapper)
+ (prof:stop-sampling))))
+ (t
+ (excl:call-next-fwrapper))))
+
+(defimplementation profile (fname)
+ (unless (acl-profiler-active-p)
+ (start-acl-profiler))
+ (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
+ (push fname *profiled-functions*))
+
+(defimplementation profiled-functions ()
+ *profiled-functions*)
+
+(defimplementation unprofile (fname)
+ (excl:funwrap fname 'profile-fwrapper)
+ (setq *profiled-functions* (remove fname *profiled-functions*)))
+
+(defimplementation profile-report ()
+ (prof:show-flat-profile :verbose nil)
+ (when *profiled-functions*
+ (start-acl-profiler)))
+
+(defimplementation profile-reset ()
+ (when (acl-profiler-active-p)
+ (stop-acl-profiler)
+ (start-acl-profiler))
+ "Reset profiling counters.")
+
;;;; Inspecting
(defclass acl-inspector (inspector)
@@ -479,7 +574,6 @@
(defimplementation make-default-inspector ()
(make-instance 'acl-inspector))
-#-allegro-v5.0
(defmethod inspect-for-emacs ((f function) inspector)
inspector
(values "A function."
@@ -498,6 +592,10 @@
inspector
(values "A function." (allegro-inspect o)))
+(defmethod inspect-for-emacs ((o standard-object) (inspector acl-inspector))
+ inspector
+ (values (format nil "~A is a standard-object." o) (allegro-inspect o)))
+
(defun allegro-inspect (o)
(loop for (d dd) on (inspect::inspect-ctl o)
append (frob-allegro-field-def o d)
@@ -506,8 +604,9 @@
(defun frob-allegro-field-def (object def)
(with-struct (inspect::field-def- name type access) def
(ecase type
- ((:unsigned-word :unsigned-byte :unsigned-natural
- :unsigned-half-long :unsigned-3byte)
+ ((:unsigned-word :unsigned-byte :unsigned-natural
+ :unsigned-long :unsigned-half-long
+ :unsigned-3byte)
(label-value-line name (inspect::component-ref-v object access type)))
((:lisp :value)
(label-value-line name (inspect::component-ref object access)))
@@ -520,8 +619,9 @@
;;;; Multithreading
-(defimplementation startup-multiprocessing ()
- (mp:start-scheduler))
+(defimplementation initialize-multiprocessing (continuation)
+ (mp:start-scheduler)
+ (funcall continuation))
(defimplementation spawn (fn &key name)
(mp:process-run-function name fn))
@@ -631,7 +731,6 @@
(eval `(trace (,fspec ,@args)))
(format nil "~S is now traced." fspec))))
-#-allegro-v5.0
(defun toggle-trace-generic-function-methods (name)
(let ((methods (mop:generic-function-methods (fdefinition name))))
(cond ((tracedp name)
@@ -655,3 +754,20 @@
,(third fspec)))))
(t
fspec)))
+
+
+;;;; Weak hashtables
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-keys t args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ (apply #'make-hash-table :values :weak args))
+
+
+;;;; Character names
+
+(defimplementation character-completion-set (prefix matchp)
+ (loop for name being the hash-keys of excl::*name-to-char-table*
+ when (funcall matchp prefix name)
+ collect (string-capitalize name)))
Modified: trunk/thirdparty/emacs/slime/swank-backend.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-backend.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-backend.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -15,6 +15,8 @@
(:export #:sldb-condition
#:original-condition
#:compiler-condition
+ #:abort-request
+ #:request-abort
#:message
#:short-message
#:condition
@@ -84,6 +86,8 @@
#:slot-definition-type
#:slot-definition-readers
#:slot-definition-writers
+ #:slot-boundp-using-class
+ #:slot-value-using-class
;; generic function protocol
#:compute-applicable-methods-using-classes
#:finalize-inheritance))
@@ -110,26 +114,67 @@
Backends implement these functions using DEFIMPLEMENTATION."
(check-type documentation string "a documentation string")
- (flet ((gen-default-impl ()
- `(defmethod ,name ,args ,@default-body)))
- `(progn (defgeneric ,name ,args (:documentation ,documentation))
- (pushnew ',name *interface-functions*)
- ,(if (null default-body)
- `(pushnew ',name *unimplemented-interfaces*)
- (gen-default-impl))
- ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler…>
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (export ',name :swank-backend))
- ',name)))
+ (assert (every #'symbolp args) ()
+ "Complex lambda-list not supported: ~S ~S" name args)
+ (labels ((gen-default-impl ()
+ `(setf (get ',name 'default) (lambda ,args ,@default-body)))
+ (args-as-list (args)
+ (destructuring-bind (req opt key rest) (parse-lambda-list args)
+ `(,@req ,@opt
+ ,@(loop for k in key append `(,(kw k) ,k))
+ ,@(or rest '(())))))
+ (parse-lambda-list (args)
+ (parse args '(&optional &key &rest)
+ (make-array 4 :initial-element nil)))
+ (parse (args keywords vars)
+ (cond ((null args)
+ (reverse (map 'list #'reverse vars)))
+ ((member (car args) keywords)
+ (parse (cdr args) (cdr (member (car args) keywords)) vars))
+ (t (push (car args) (aref vars (length keywords)))
+ (parse (cdr args) keywords vars))))
+ (kw (s) (intern (string s) :keyword)))
+ `(progn
+ (defun ,name ,args
+ ,documentation
+ (let ((f (or (get ',name 'implementation)
+ (get ',name 'default))))
+ (cond (f (apply f ,@(args-as-list args)))
+ (t (error "~S not implementated" ',name)))))
+ (pushnew ',name *interface-functions*)
+ ,(if (null default-body)
+ `(pushnew ',name *unimplemented-interfaces*)
+ (gen-default-impl))
+ ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler…>
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (export ',name :swank-backend))
+ ',name)))
(defmacro defimplementation (name args &body body)
- `(progn (defmethod ,name ,args ,@body)
- (if (member ',name *interface-functions*)
- (setq *unimplemented-interfaces*
- (remove ',name *unimplemented-interfaces*))
- (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
- ',name))
+ (assert (every #'symbolp args) ()
+ "Complex lambda-list not supported: ~S ~S" name args)
+ `(progn
+ (setf (get ',name 'implementation) (lambda ,args ,@body))
+ (if (member ',name *interface-functions*)
+ (setq *unimplemented-interfaces*
+ (remove ',name *unimplemented-interfaces*))
+ (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
+ ',name))
+(define-condition request-abort (error)
+ ((reason :initarg :reason :reader reason))
+ (:report (lambda (condition stream)
+ (princ (reason condition) stream)))
+ (:documentation "Condition signalled when SLIME wasn't able to
+complete a user request due to bad data. This condition is not
+for real errors but for situations where SLIME has to give up and
+return control back to the user."))
+
+(defun abort-request (reason-control &rest reason-args)
+ "Abort whatever swank is currently do and send a message to the
+user."
+ (error 'request-abort :reason (apply #'format nil reason-control reason-args)))
+
(defun warn-unimplemented-interfaces ()
"Warn the user about unimplemented backend features.
The portable code calls this function at startup."
@@ -155,6 +200,31 @@
(import real-symbol :swank-mop)
(export real-symbol :swank-mop)))))
+(defvar *gray-stream-symbols*
+ '(:fundamental-character-output-stream
+ :stream-write-char
+ :stream-fresh-line
+ :stream-force-output
+ :stream-finish-output
+ :fundamental-character-input-stream
+ :stream-read-char
+ :stream-listen
+ :stream-unread-char
+ :stream-clear-input
+ :stream-line-column
+ :stream-read-char-no-hang
+ ;; STREAM-LINE-LENGTH is an extension to gray streams that's apparently
+ ;; supported by CMUCL, OpenMCL, SBCL and SCL.
+ #+(or cmu openmcl sbcl scl)
+ :stream-line-length))
+
+(defun import-from (package symbol-names &optional (to-package *package*))
+ "Import the list of SYMBOL-NAMES found in the package PACKAGE."
+ (dolist (name symbol-names)
+ (multiple-value-bind (symbol found) (find-symbol (string name) package)
+ (assert found () "Symbol ~A not found in package ~A" name package)
+ (import symbol to-package))))
+
;;;; Utilities
@@ -186,9 +256,10 @@
(definterface close-socket (socket)
"Close the socket SOCKET.")
-(definterface accept-connection (socket &key external-format)
- "Accept a client connection on the listening socket SOCKET. Return
-a stream for the new connection.")
+(definterface accept-connection (socket &key external-format
+ buffering timeout)
+ "Accept a client connection on the listening socket SOCKET.
+Return a stream for the new connection.")
(definterface add-sigio-handler (socket fn)
"Call FN whenever SOCKET is readable.")
@@ -206,6 +277,12 @@
"Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
nil)
+(definterface set-stream-timeout (stream timeout)
+ "Set the 'stream 'timeout. The timeout is either the real number
+ specifying the timeout in seconds or 'nil for no timeout."
+ (declare (ignore stream timeout))
+ nil)
+
;;; Base condition for networking errors.
(define-condition network-error (simple-error) ())
@@ -285,17 +362,19 @@
Example:
\(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"
(unless (member :asdf *features*)
- (error "ASDF is not loaded."))
+ (abort-request "ASDF is not loaded."))
(with-compilation-hooks ()
- (let ((operate (find-symbol "OPERATE" :asdf))
+ (let ((operate (find-symbol (symbol-name '#:operate) :asdf))
(operation (find-symbol operation-name :asdf)))
(when (null operation)
- (error "Couldn't find ASDF operation ~S" operation-name))
+ (abort-request "Couldn't find ASDF operation ~S" operation-name))
(apply operate operation system-name keyword-args))))
-(definterface swank-compile-file (filename load-p)
+(definterface swank-compile-file (filename load-p external-format)
"Compile FILENAME signalling COMPILE-CONDITIONs.
-If LOAD-P is true, load the file after compilation.")
+If LOAD-P is true, load the file after compilation.
+EXTERNAL-FORMAT is a value returned by find-external-format or
+:default.")
(deftype severity ()
'(member :error :read-error :warning :style-warning :note))
@@ -327,6 +406,48 @@
(location :initarg :location
:accessor location)))
+(definterface find-external-format (coding-system)
+ "Return a \"external file format designator\" for CODING-SYSTEM.
+CODING-SYSTEM is Emacs-style coding system name (a string),
+e.g. \"latin-1-unix\"."
+ (if (equal coding-system "iso-latin-1-unix")
+ :default
+ nil))
+
+(definterface guess-external-format (filename)
+ "Detect the external format for the file with name FILENAME.
+Return nil if the file contains no special markers."
+ ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
+ (with-open-file (s filename :if-does-not-exist nil
+ :external-format (or (find-external-format "latin-1-unix")
+ :default))
+ (or (let* ((line (read-line s nil))
+ (p (search "-*-" line)))
+ (when p
+ (let* ((start (+ p (length "-*-")))
+ (end (search "-*-" line :start2 start)))
+ (when end
+ (%search-coding line start end)))))
+ (let* ((len (file-length s))
+ (buf (make-string (min len 3000))))
+ (file-position s (- len (length buf)))
+ (read-sequence buf s)
+ (let ((start (search "Local Variables:" buf :from-end t))
+ (end (search "End:" buf :from-end t)))
+ (and start end (< start end)
+ (%search-coding buf start end)))))))
+
+(defun %search-coding (str start end)
+ (let ((p (search "coding:" str :start2 start :end2 end)))
+ (when p
+ (incf p (length "coding:"))
+ (loop while (and (< p end)
+ (member (aref str p) '(#\space #\tab)))
+ do (incf p))
+ (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
+ str :start p)))
+ (find-external-format (subseq str p end))))))
+
;;;; Streams
@@ -373,17 +494,40 @@
"Recursively expand all macros in FORM.
Return the resulting form.")
+(definterface compiler-macroexpand-1 (form &optional env)
+ "Call the compiler-macro for form.
+If FORM is a function call for which a compiler-macro has been
+defined, invoke the expander function using *macroexpand-hook* and
+return the results and T. Otherwise, return the original form and
+NIL."
+ (let ((fun (and (consp form) (compiler-macro-function (car form)))))
+ (if fun
+ (let ((result (funcall *macroexpand-hook* fun form env)))
+ (values result (not (eq result form))))
+ (values form nil))))
+
+(definterface compiler-macroexpand (form &optional env)
+ "Repetitively call `compiler-macroexpand-1'."
+ (labels ((frob (form expanded)
+ (multiple-value-bind (new-form newly-expanded)
+ (compiler-macroexpand-1 form env)
+ (if newly-expanded
+ (frob new-form t)
+ (values new-form expanded)))))
+ (frob form env)))
+
(definterface describe-symbol-for-emacs (symbol)
"Return a property list describing SYMBOL.
The property list has an entry for each interesting aspect of the
symbol. The recognised keys are:
- :VARIABLE :FUNCTION :SETF :TYPE :CLASS :MACRO :COMPILER-MACRO
- :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
+ :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
+ :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
The value of each property is the corresponding documentation string,
-or :NOT-DOCUMENTED. It is legal to include keys not listed here.
+or :NOT-DOCUMENTED. It is legal to include keys not listed here (but
+slime-print-apropos in Emacs must know about them).
Properties should be included if and only if they are applicable to
the symbol. For example, only (and all) fbound symbols should include
@@ -404,6 +548,12 @@
;;;; Debugging
+(definterface install-debugger-globally (function)
+ "Install FUNCTION as the debugger for all threads/processes. This
+usually involves setting *DEBUGGER-HOOK* and, if the implementation
+permits, hooking into BREAK as well."
+ (setq *debugger-hook* function))
+
(definterface call-with-debugging-environment (debugger-loop-fn)
"Call DEBUGGER-LOOP-FN in a suitable debugging environment.
@@ -530,7 +680,22 @@
(definterface sldb-break-at-start (symbol)
"Set a breakpoint on the beginning of the function for SYMBOL.")
+(definterface sldb-stepper-condition-p (condition)
+ "Return true if SLDB was invoked due to a single-stepping condition,
+false otherwise. "
+ (declare (ignore condition))
+ nil)
+(definterface sldb-step-into ()
+ "Step into the current single-stepper form.")
+
+(definterface sldb-step-next ()
+ "Step to the next form in the current function.")
+
+(definterface sldb-step-out ()
+ "Stop single-stepping temporarily, but resume it once the current function
+returns.")
+
;;;; Definition finding
@@ -661,8 +826,9 @@
(definterface make-default-inspector ()
"Return an inspector object suitable for passing to inspect-for-emacs.")
-(definterface inspect-for-emacs (object inspector)
- "Explain to emacs how to inspect OBJECT.
+(defgeneric inspect-for-emacs (object inspector)
+ (:documentation
+ "Explain to Emacs how to inspect OBJECT.
The argument INSPECTOR is an object representing how to get at
the internals of OBJECT, it is usually an implementation specific
@@ -687,7 +853,7 @@
(:action label lambda) - Render LABEL (a text string) which when
clicked will call LAMBDA.
- NIL - do nothing.")
+ NIL - do nothing."))
(defmethod inspect-for-emacs ((object t) (inspector t))
"Generic method for inspecting any kind of object.
@@ -695,13 +861,12 @@
Since we don't know how to deal with OBJECT we simply dump the
output of CL:DESCRIBE."
(declare (ignore inspector))
- (values "A value."
- `("Type: " (:value ,(type-of object))
- (:newline)
- "Don't know how to inspect the object, dumping output of CL:DESCIRBE:"
- (:newline) (:newline)
- ,(with-output-to-string (desc)
- (describe object desc)))))
+ (values
+ "A value."
+ `("Type: " (:value ,(type-of object)) (:newline)
+ "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
+ (:newline) (:newline)
+ ,(with-output-to-string (desc) (describe object desc)))))
;;; Utilities for inspector methods.
;;;
@@ -724,14 +889,11 @@
;;; The default implementations are sufficient for non-multiprocessing
;;; implementations.
-(definterface startup-multiprocessing ()
- "Initialize multiprocessing, if necessary.
+(definterface initialize-multiprocessing (continuation)
+ "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
-This function is called directly through the listener, not in an RPC
-from Emacs. This is to support interfaces such as CMUCL's
-MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS which does not return like a
-normal function."
- nil)
+Depending on the impleimentaion, this function may never return."
+ (funcall continuation))
(definterface spawn (fn &key name)
"Create a new thread to call FN.")
@@ -772,6 +934,24 @@
(type function function))
(funcall function))
+(definterface make-recursive-lock (&key name)
+ "Make a lock for thread synchronization.
+Only one thread may hold the lock (via CALL-WITH-RECURSIVE-LOCK-HELD)
+at a time, but that thread may hold it more than once."
+ (cons nil (make-lock :name name)))
+
+(definterface call-with-recursive-lock-held (lock function)
+ "Call FUNCTION with LOCK held, queueing if necessary."
+ (if (eql (car lock) (current-thread))
+ (funcall function)
+ (call-with-lock-held (cdr lock)
+ (lambda ()
+ (unwind-protect
+ (progn
+ (setf (car lock) (current-thread))
+ (funcall function))
+ (setf (car lock) nil))))))
+
(definterface current-thread ()
"Return the currently executing thread."
0)
@@ -806,3 +986,26 @@
(:call CALLER CALLEE) ; trace calls from CALLER to CALLEE.
(:labels TOPLEVEL LOCAL)
(:flet TOPLEVEL LOCAL) ")
+
+
+;;;; Weak datastructures
+
+(definterface make-weak-key-hash-table (&rest args)
+ "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
+ (apply #'make-hash-table args))
+
+(definterface make-weak-value-hash-table (&rest args)
+ "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
+ (apply #'make-hash-table args))
+
+
+;;;; Character names
+
+(definterface character-completion-set (prefix matchp)
+ "Return a list of names of characters that match PREFIX."
+ ;; Handle the standard and semi-standard characters.
+ (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
+ "Linefeed" "Return" "Backspace")
+ when (funcall matchp prefix name)
+ collect name))
+
Modified: trunk/thirdparty/emacs/slime/swank-clisp.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-clisp.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-clisp.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -2,24 +2,34 @@
;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
-;;;; swank-clisp.lisp is free software; you can redistribute it and/or
+;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License as
-;;;; published by the Free Software Foundation; either version 2, or
-;;;; (at your option) any later version.
+;;;; published by the Free Software Foundation; either version 2 of
+;;;; the License, or (at your option) any later version.
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with this program; if not, write to the Free
+;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+;;;; MA 02111-1307, USA.
+
;;; This is work in progress, but it's already usable. Many things
;;; are adapted from other swank-*.lisp, in particular from
;;; swank-allegro (I don't use allegro at all, but it's the shortest
;;; one and I found Helmut Eller's code there enlightening).
-;;; This code is developed using the current CVS version of CLISP and
-;;; CLISP 2.32 on Linux. Older versions may not work (2.29 and below
-;;; are confirmed non-working; please upgrade). You need an image
-;;; containing the "SOCKET", "REGEXP", and "LINUX" packages. The
-;;; portable xref from the CMU AI repository and metering.lisp from
-;;; CLOCC [1] are also required (alternatively, you have to manually
-;;; comment out some code below).
-;;;
+;;; This code will work better with recent versions of CLISP (say, the
+;;; last release or CVS HEAD) while it may not work at all with older
+;;; versions. It is reasonable to expect it to work on platforms with
+;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
+;;; systems, but also on Win32. This backend uses the portable xref
+;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
+;;; are conveniently included in SLIME.
+
;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
(in-package :swank-backend)
@@ -28,12 +38,8 @@
;;(use-package "SOCKET")
(use-package "GRAY"))
-(eval-when (:compile-toplevel :execute)
- (when (find-package "LINUX")
- (pushnew :linux *features*)))
-
-;;;; if this listp has the complete CLOS then we use it, othewise we
-;;;; build up a "fake" swank-mop and then overide the methods in the
+;;;; if this lisp has the complete CLOS then we use it, otherwise we
+;;;; build up a "fake" swank-mop and then override the methods in the
;;;; inspector.
(eval-when (:compile-toplevel :load-toplevel :execute)
@@ -42,7 +48,7 @@
(eql :external
(nth-value 1 (find-symbol (string ':standard-slot-definition)
:clos))))
- "True in those CLISP imagse which have a complete MOP implementation."))
+ "True in those CLISP images which have a complete MOP implementation."))
#+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
(progn
@@ -57,44 +63,40 @@
(:documentation
"Dummy class created so that swank.lisp will compile and load."))
-#+linux
-(defmacro with-blocked-signals ((&rest signals) &body body)
- (ext:with-gensyms ("SIGPROCMASK" ret mask)
- `(multiple-value-bind (,ret ,mask)
- (linux:sigprocmask-set-n-save
- ,linux:SIG_BLOCK
- ,(do ((sigset (linux:sigset-empty)
- (linux:sigset-add sigset (the fixnum (pop signals)))))
- ((null signals) sigset)))
- (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
- (unwind-protect
- (progn ,@body)
- (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
+;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or))
+;; (progn
+;; (defmacro with-blocked-signals ((&rest signals) &body body)
+;; (ext:with-gensyms ("SIGPROCMASK" ret mask)
+;; `(multiple-value-bind (,ret ,mask)
+;; (linux:sigprocmask-set-n-save
+;; ,linux:SIG_BLOCK
+;; ,(do ((sigset (linux:sigset-empty)
+;; (linux:sigset-add sigset (the fixnum (pop signals)))))
+;; ((null signals) sigset)))
+;; (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
+;; (unwind-protect
+;; (progn ,@body)
+;; (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
-;; XXX currently only works in CVS version. 2.32 breaks.
-;; #+linux
-;; (defimplementation call-without-interrupts (fn)
-;; (with-blocked-signals (#.linux:SIGINT) (funcall fn)))
-;;
-;; #-linux
+;; (defimplementation call-without-interrupts (fn)
+;; (with-blocked-signals (#.linux:SIGINT) (funcall fn))))
+
+;; #+#.(cl:if (cl:find-package "LINUX") '(or) '(and))
(defimplementation call-without-interrupts (fn)
(funcall fn))
-#+unix
-(defmethod getpid ()
- (funcall (or (find-symbol "PROGRAM-ID" :system)
- (find-symbol "PROCESS-ID" :system)
- (error "getpid not implemented"))))
+(let ((getpid (or (find-symbol "PROCESS-ID" :system)
+ ;; old name prior to 2005-03-01, clisp <= 2.33.2
+ (find-symbol "PROGRAM-ID" :system)
+ #+win32 ; integrated into the above since 2005-02-24
+ (and (find-package :win32) ; optional modules/win32
+ (find-symbol "GetCurrentProcessId" :win32)))))
+ (defimplementation getpid () ; a required interface
+ (cond
+ (getpid (funcall getpid))
+ #+win32 ((ext:getenv "PID")) ; where does that come from?
+ (t -1))))
-#+win32
-(defmethod getpid ()
- (cond ((find-package :win32)
- (funcall (find-symbol "GetCurrentProcessId" :win32)))
- (t
- (system::getenv "PID"))))
-
-;; the above is likely broken; we need windows NT users!
-
(defimplementation lisp-implementation-type-name ()
"clisp")
@@ -114,26 +116,45 @@
(defimplementation close-socket (socket)
(socket:socket-server-close socket))
-
-(defun find-encoding (external-format)
- (ecase external-format
- (:iso-latin-1-unix (ext:make-encoding :charset 'charset:iso-8859-1
- :line-terminator :unix))
- (:utf-8-unix (ext:make-encoding :charset 'charset:utf-8
- :line-terminator :unix))))
(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix))
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout))
(socket:socket-accept socket
:buffered nil ;; XXX should be t
:element-type 'character
- :external-format (find-encoding external-format)))
+ :external-format external-format))
+;;; Coding systems
+
+(defvar *external-format-to-coding-system*
+ '(((:charset "iso-8859-1" :line-terminator :unix)
+ "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
+ ((:charset "iso-8859-1":latin-1)
+ "latin-1" "iso-latin-1" "iso-8859-1")
+ ((:charset "utf-8") "utf-8")
+ ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
+ ((:charset "euc-jp") "euc-jp")
+ ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
+ ((:charset "us-ascii") "us-ascii")
+ ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (let ((args (car (rassoc-if (lambda (x)
+ (member coding-system x :test #'equal))
+ *external-format-to-coding-system*))))
+ (and args (apply #'ext:make-encoding args))))
+
+
;;; Swank functions
(defimplementation arglist (fname)
(block nil
- (or (ignore-errors (return (ext:arglist fname)))
+ (or (ignore-errors
+ (let ((exp (function-lambda-expression fname)))
+ (and exp (return (second exp)))))
+ (ignore-errors
+ (return (ext:arglist fname)))
:not-available)))
(defimplementation macroexpand-all (form)
@@ -143,18 +164,44 @@
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
(let ((result ()))
- (labels ((doc (kind)
- (or (documentation symbol kind) :not-documented))
- (maybe-push (property value)
- (when value
- (setf result (list* property value result)))))
+ (flet ((doc (kind)
+ (or (documentation symbol kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push :variable (when (boundp symbol) (doc 'variable)))
(when (fboundp symbol)
- (if (macro-function symbol)
- (setf (getf result :macro) (doc 'function))
- (setf (getf result :function) (doc 'function))))
- (maybe-push :variable (when (boundp symbol) (doc 'variable)))
- (maybe-push :class (when (find-class symbol nil)
- (doc 'type))) ;this should be fixed
+ (maybe-push
+ ;; Report WHEN etc. as macros, even though they may be
+ ;; implemented as special operators.
+ (if (macro-function symbol) :macro
+ (typecase (fdefinition symbol)
+ (generic-function :generic-function)
+ (function :function)
+ ;; (type-of 'progn) -> ext:special-operator
+ (t :special-operator)))
+ (doc 'function)))
+ (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
+ (get symbol 'system::setf-expander)); defsetf
+ (maybe-push :setf (doc 'setf)))
+ (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
+ (get symbol 'system::defstruct-description)
+ (get symbol 'system::deftype-expander))
+ (maybe-push :type (doc 'type))) ; even for 'structure
+ (when (find-class symbol nil)
+ (maybe-push :class (doc 'type)))
+ ;; Let this code work compiled in images without FFI
+ (let ((types (load-time-value
+ (and (find-package "FFI")
+ (symbol-value
+ (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
+ ;; Use ffi::*c-type-table* so as not to suffer the overhead of
+ ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
+ ;; which are not FFI type names.
+ (when (and types (nth-value 1 (gethash symbol types)))
+ ;; Maybe use (case (head (ffi:deparse-c-type)))
+ ;; to distinguish struct and union types?
+ (maybe-push :alien-type :not-documented)))
result)))
(defimplementation describe-definition (symbol namespace)
@@ -165,21 +212,30 @@
(:class (describe (find-class symbol)))))
(defun fspec-pathname (symbol)
- (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
- (if (and path
- (member (pathname-type path)
- custom:*compiled-file-types* :test #'string=))
- (loop for suffix in custom:*source-file-types*
- thereis (make-pathname :defaults path :type suffix))
- path)))
+ (let ((path (documentation symbol 'sys::file))
+ lines)
+ (when (consp path)
+ (psetq path (car path)
+ lines (cdr path)))
+ (when (and path
+ (member (pathname-type path)
+ custom:*compiled-file-types* :test #'equal))
+ (setq path
+ (loop for suffix in custom:*source-file-types*
+ thereis (probe-file (make-pathname :defaults path
+ :type suffix)))))
+ (values path lines)))
(defun fspec-location (fspec)
- (let ((file (fspec-pathname fspec)))
+ (multiple-value-bind (file lines)
+ (fspec-pathname fspec)
(cond (file
(multiple-value-bind (truename c) (ignore-errors (truename file))
- (cond (truename
+ (cond (truename
(make-location (list :file (namestring truename))
- (list :function-name (string fspec))))
+ (if (consp lines)
+ (list* :line lines)
+ (list :function-name (string fspec)))))
(t (list :error (princ-to-string c))))))
(t (list :error (format nil "No source information available for: ~S"
fspec))))))
@@ -187,61 +243,97 @@
(defimplementation find-definitions (name)
(list (list name (fspec-location name))))
-(defvar *sldb-topframe*)
-(defvar *sldb-botframe*)
-(defvar *sldb-source*)
-(defvar *sldb-debugmode* 4)
+(defun trim-whitespace (string)
+ (string-trim #(#\newline #\space #\tab) string))
-(defun frame-down (frame)
- (sys::frame-down-1 frame sys::*debug-mode*))
+(defvar *sldb-backtrace*)
-(defun frame-up (frame)
- (sys::frame-up-1 frame sys::*debug-mode*))
-
(defimplementation call-with-debugging-environment (debugger-loop-fn)
- (let* ((sys::*break-count* (1+ sys::*break-count*))
- (sys::*driver* debugger-loop-fn)
- (sys::*fasoutput-stream* nil)
- (sys::*frame-limit1* (sys::frame-limit1 0))
- (sys::*frame-limit2* (sys::frame-limit2))
- (sys::*debug-mode* *sldb-debugmode*)
- (*sldb-topframe* sys::*frame-limit1*))
+ (let* (;;(sys::*break-count* (1+ sys::*break-count*))
+ ;;(sys::*driver* debugger-loop-fn)
+ ;;(sys::*fasoutput-stream* nil)
+ (*sldb-backtrace* (nthcdr 5 (sldb-backtrace))))
(funcall debugger-loop-fn)))
-(defun nth-frame (index)
- (loop for frame = *sldb-topframe* then (frame-up frame)
- repeat index
- finally (return frame)))
+(defun nth-frame (index)
+ (nth index *sldb-backtrace*))
+;; This is the old backtrace implementation. Not sure yet wheter the
+;; new is much better.
+;;
+;;(defimplementation compute-backtrace (start end)
+;; (let ((end (or end most-positive-fixnum)))
+;; (loop for last = nil then frame
+;; for frame = (nth-frame start) then (frame-up frame)
+;; for i from start below end
+;; until (or (eq frame last) (not frame))
+;; collect frame)))
+;;
+;;(defimplementation print-frame (frame stream)
+;; (write-string (trim-whitespace
+;; (with-output-to-string (stream)
+;; (sys::describe-frame stream frame)))
+;; stream))
+;;
+;;(defimplementation frame-locals (frame-number)
+;; (let* ((frame (nth-frame frame-number))
+;; (frame-env (sys::eval-at frame '(sys::the-environment))))
+;; (append
+;; (frame-do-venv frame (svref frame-env 0))
+;; (frame-do-fenv frame (svref frame-env 1))
+;; (frame-do-benv frame (svref frame-env 2))
+;; (frame-do-genv frame (svref frame-env 3))
+;; (frame-do-denv frame (svref frame-env 4)))))
+;;
+;;(defimplementation frame-var-value (frame var)
+;; (getf (nth var (frame-locals frame)) :value))
+
+(defun format-frame (frame)
+ (trim-whitespace
+ (with-output-to-string (s)
+ (sys::describe-frame s frame))))
+
+(defun function-frame-p (frame)
+ ;; We are interested in frames which like look "<5> foo ...".
+ ;; Ugly, I know.
+ (char= #\< (aref (format-frame frame) 0)))
+
+(defun sldb-backtrace ()
+ "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
+ (do ((fframes '())
+ (last nil frame)
+ (frame (sys::the-frame) (sys::frame-up-1 frame 1)))
+ ((eq frame last) (nreverse fframes))
+ (when (function-frame-p frame)
+ (push (cons frame (format-frame frame)) fframes))))
+
(defimplementation compute-backtrace (start end)
- (let ((end (or end most-positive-fixnum)))
- (loop for last = nil then frame
- for frame = (nth-frame start) then (frame-up frame)
- for i from start below end
- until (or (eq frame last) (system::driver-frame-p frame))
- collect frame)))
+ (let* ((bt *sldb-backtrace*)
+ (len (length bt)))
+ (subseq bt start (min (or end len) len))))
(defimplementation print-frame (frame stream)
- (write-string (string-left-trim '(#\Newline)
- (with-output-to-string (stream)
- (sys::describe-frame stream frame)))
- stream))
+ (let ((desc (cdr frame)))
+ (write-string (subseq (cdr frame)
+ (+ (position #\> desc) 2)
+ (position #\newline desc))
+ stream)))
+(defimplementation format-sldb-condition (condition)
+ (trim-whitespace (princ-to-string condition)))
+
(defimplementation eval-in-frame (form frame-number)
- (sys::eval-at (nth-frame frame-number) form))
+ (sys::eval-at (car (nth-frame frame-number)) form))
-(defimplementation frame-locals (frame-number)
- (let* ((frame (nth-frame frame-number))
- (frame-env (sys::eval-at frame '(sys::the-environment))))
- (append
- (frame-do-venv frame (svref frame-env 0))
- (frame-do-fenv frame (svref frame-env 1))
- (frame-do-benv frame (svref frame-env 2))
- (frame-do-genv frame (svref frame-env 3))
- (frame-do-denv frame (svref frame-env 4)))))
+;; Don't know how to access locals. Return some strings instead.
+;; Maybe we should search some frame nearby with a 'sys::the-environment?
+(defimplementation frame-locals (frame-number)
+ (let ((desc (cdr (nth-frame frame-number))))
+ (list (list :name :|| :id 0
+ :value (trim-whitespace
+ (subseq desc (position #\newline desc)))))))
-(defimplementation frame-var-value (frame var)
- (getf (nth var (frame-locals frame)) :value))
+(defimplementation frame-var-value (frame var) nil)
;; Interpreter-Variablen-Environment has the shape
;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
@@ -278,17 +370,15 @@
nil)
(defimplementation return-from-frame (index form)
- (sys::return-from-eval-frame (nth-frame index) form))
+ (sys::return-from-eval-frame (car (nth-frame index)) form))
(defimplementation restart-frame (index)
- (sys::redo-eval-frame (nth-frame index)))
+ (sys::redo-eval-frame (car (nth-frame index))))
(defimplementation frame-source-location-for-emacs (index)
- (let ((f (nth-frame index)))
- (list :error (format nil "Cannot find source for frame: ~A ~A ~A"
- f
- (sys::eval-frame-p f)
- (sys::the-frame)))))
+ `(:error
+ ,(format nil "frame-source-location not implemented. (frame: ~A)"
+ (car (nth-frame index)))))
;;; Profiling
@@ -390,10 +480,11 @@
:message (princ-to-string condition)
:location (compiler-note-location))))
-(defimplementation swank-compile-file (filename load-p)
+(defimplementation swank-compile-file (filename load-p external-format)
(with-compilation-hooks ()
(with-compilation-unit ()
- (let ((fasl-file (compile-file filename)))
+ (let ((fasl-file (compile-file filename
+ :external-format external-format)))
(when (and load-p fasl-file)
(load fasl-file))
nil))))
Modified: trunk/thirdparty/emacs/slime/swank-cmucl.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-cmucl.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-cmucl.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -94,13 +94,15 @@
(nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
(defimplementation close-socket (socket)
- (sys:invalidate-descriptor socket)
- (ext:close-socket (socket-fd socket)))
+ (let ((fd (socket-fd socket)))
+ (sys:invalidate-descriptor fd)
+ (ext:close-socket fd)))
-(defimplementation accept-connection (socket &key external-format)
- (let ((ef (or external-format :iso-latin-1-unix)))
- (assert (eq ef ':iso-latin-1-unix))
- (make-socket-io-stream (ext:accept-tcp-connection socket))))
+(defimplementation accept-connection (socket &key
+ external-format buffering timeout)
+ (declare (ignore timeout external-format))
+ (let ((buffering (or buffering :full)))
+ (make-socket-io-stream (ext:accept-tcp-connection socket) buffering)))
;;;;; Sockets
@@ -115,9 +117,10 @@
(let ((hostent (ext:lookup-host-entry hostname)))
(car (ext:host-entry-addr-list hostent))))
-(defun make-socket-io-stream (fd)
+(defun make-socket-io-stream (fd buffering)
"Create a new input/output fd-stream for FD."
- (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
+ (sys:make-fd-stream fd :input t :output t :element-type 'base-char
+ :buffering buffering))
;;;;; Signal-driven I/O
@@ -149,16 +152,13 @@
(defimplementation remove-sigio-handlers (socket)
(let ((fd (socket-fd socket)))
(setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
- (sys:invalidate-descriptor fd))
- (close socket))
+ (sys:invalidate-descriptor fd)))
;;;;; SERVE-EVENT
(defimplementation add-fd-handler (socket fn)
(let ((fd (socket-fd socket)))
- (sys:add-fd-handler fd :input (lambda (_)
- _
- (funcall fn)))))
+ (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn)))))
(defimplementation remove-fd-handlers (socket)
(sys:invalidate-descriptor (socket-fd socket)))
@@ -181,40 +181,61 @@
(:print-function %print-slime-output-stream)
(:constructor make-slime-output-stream (output-fn)))
(output-fn nil :type function)
- (buffer (make-string 512) :type string)
+ (buffer (make-string 8000) :type string)
(index 0 :type kernel:index)
- (column 0 :type kernel:index))
+ (column 0 :type kernel:index)
+ (last-flush-time (get-internal-real-time) :type unsigned-byte))
(defun %print-slime-output-stream (s stream d)
(declare (ignore d))
(print-unreadable-object (s stream :type t :identity t)))
(defun sos/out (stream char)
- (let ((buffer (sos.buffer stream))
- (index (sos.index stream)))
- (setf (schar buffer index) char)
- (setf (sos.index stream) (1+ index))
- (incf (sos.column stream))
- (when (char= #\newline char)
- (setf (sos.column stream) 0)
- (force-output stream))
- (when (= index (1- (length buffer)))
- (force-output stream)))
- char)
+ (system:without-interrupts
+ (let ((buffer (sos.buffer stream))
+ (index (sos.index stream)))
+ (setf (schar buffer index) char)
+ (setf (sos.index stream) (1+ index))
+ (incf (sos.column stream))
+ (when (char= #\newline char)
+ (setf (sos.column stream) 0)
+ (force-output stream))
+ (when (= index (1- (length buffer)))
+ (finish-output stream)))
+ char))
(defun sos/sout (stream string start end)
- (loop for i from start below end
- do (sos/out stream (aref string i))))
+ (system:without-interrupts
+ (loop for i from start below end
+ do (sos/out stream (aref string i)))))
+(defun log-stream-op (stream operation)
+ stream operation
+ #+(or)
+ (progn
+ (format sys:*tty* "~S @ ~D ~A~%" operation
+ (sos.index stream)
+ (/ (- (get-internal-real-time) (sos.last-flush-time stream))
+ (coerce internal-time-units-per-second 'double-float)))
+ (finish-output sys:*tty*)))
+
(defun sos/misc (stream operation &optional arg1 arg2)
(declare (ignore arg1 arg2))
(case operation
- ((:force-output :finish-output)
- (let ((end (sos.index stream)))
- (unless (zerop end)
- (let ((s (subseq (sos.buffer stream) 0 end)))
- (setf (sos.index stream) 0)
- (funcall (sos.output-fn stream) s)))))
+ (:finish-output
+ (log-stream-op stream operation)
+ (system:without-interrupts
+ (let ((end (sos.index stream)))
+ (unless (zerop end)
+ (let ((s (subseq (sos.buffer stream) 0 end)))
+ (setf (sos.index stream) 0)
+ (funcall (sos.output-fn stream) s))
+ (setf (sos.last-flush-time stream) (get-internal-real-time)))))
+ nil)
+ (:force-output
+ (log-stream-op stream operation)
+ (sos/misc-force-output stream)
+ nil)
(:charpos (sos.column stream))
(:line-length 75)
(:file-position nil)
@@ -223,6 +244,19 @@
(:close nil)
(t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
+(defun sos/misc-force-output (stream)
+ (system:without-interrupts
+ (unless (or (zerop (sos.index stream))
+ (loop with buffer = (sos.buffer stream)
+ for i from 0 below (sos.index stream)
+ always (char= (aref buffer i) #\newline)))
+ (let ((last (sos.last-flush-time stream))
+ (now (get-internal-real-time)))
+ (when (> (/ (- now last)
+ (coerce internal-time-units-per-second 'double-float))
+ 0.1)
+ (finish-output stream))))))
+
(defstruct (slime-input-stream
(:include string-stream
(lisp::in #'sis/in)
@@ -238,10 +272,10 @@
(index 0 :type kernel:index))
(defun sis/in (stream eof-errorp eof-value)
+ (finish-output (sis.sos stream))
(let ((index (sis.index stream))
(buffer (sis.buffer stream)))
(when (= index (length buffer))
- (force-output (sis.sos stream))
(let ((string (funcall (sis.input-fn stream))))
(cond ((zerop (length string))
(return-from sis/in
@@ -271,7 +305,8 @@
(:line-length nil)
(:get-command nil)
(:element-type 'base-char)
- (:close nil)))
+ (:close nil)
+ (:interactive-p t)))
;;;; Compilation Commands
@@ -298,7 +333,8 @@
(c::warning #'handle-notification-condition))
(funcall function))))
-(defimplementation swank-compile-file (filename load-p)
+(defimplementation swank-compile-file (filename load-p external-format)
+ (declare (ignore external-format))
(clear-xref-info filename)
(with-compilation-hooks ()
(let ((*buffer-name* nil)
@@ -1101,7 +1137,10 @@
(defun setf-definitions (name)
(let ((function (or (ext:info :setf :inverse name)
- (ext:info :setf :expander name))))
+ (ext:info :setf :expander name)
+ (and (symbolp name)
+ (fboundp `(setf ,name))
+ (fdefinition `(setf ,name))))))
(if function
(list (list `(setf ,name)
(function-location (coerce function 'function)))))))
@@ -1176,16 +1215,14 @@
(declare (ignore kind))
(if (or (boundp symbol) recorded-p)
(doc 'variable))))
+ (when (fboundp symbol)
+ (maybe-push
+ (cond ((macro-function symbol) :macro)
+ ((special-operator-p symbol) :special-operator)
+ ((genericp (fdefinition symbol)) :generic-function)
+ (t :function))
+ (doc 'function)))
(maybe-push
- :generic-function
- (if (and (fboundp symbol)
- (typep (fdefinition symbol) 'generic-function))
- (doc 'function)))
- (maybe-push
- :function (if (and (fboundp symbol)
- (not (typep (fdefinition symbol) 'generic-function)))
- (doc 'function)))
- (maybe-push
:setf (if (or (ext:info setf inverse symbol)
(ext:info setf expander symbol))
(doc 'setf)))
@@ -1236,19 +1273,16 @@
(list symbol))))
((:defined)
(ext:info :alien-type :definition symbol))
- (:unknown
- (return-from describe-definition
- (format nil "Unknown alien type: ~S" symbol))))))))
+ (:unknown :unkown))))))
;;;;; Argument lists
-(defimplementation arglist ((name symbol))
- (arglist (or (macro-function name)
- (symbol-function name))))
+(defimplementation arglist (fun)
+ (etypecase fun
+ (function (function-arglist fun))
+ (symbol (function-arglist (or (macro-function fun)
+ (symbol-function fun))))))
-(defimplementation arglist ((fun function))
- (function-arglist fun))
-
(defun function-arglist (fun)
(let ((arglist
(cond ((eval:interpreted-function-p fun)
@@ -1392,6 +1426,12 @@
(defimplementation macroexpand-all (form)
(walker:macroexpand-all form))
+(defimplementation compiler-macroexpand-1 (form &optional env)
+ (ext:compiler-macroexpand-1 form env))
+
+(defimplementation compiler-macroexpand (form &optional env)
+ (ext:compiler-macroexpand form env))
+
(defimplementation set-default-directory (directory)
(setf (ext:default-directory) (namestring directory))
;; Setting *default-pathname-defaults* to an absolute directory
@@ -1432,7 +1472,12 @@
(error (make-condition
'sldb-condition
:original-condition condition)))))
- (funcall debugger-loop-fn))))
+ (unwind-protect
+ (progn
+ #+(or)(sys:scrub-control-stack)
+ (funcall debugger-loop-fn))
+ #+(or)(sys:scrub-control-stack)
+ ))))
(defun frame-down (frame)
(handler-case (di:frame-down frame)
@@ -1662,9 +1707,12 @@
(values :initarg :values :reader breakpoint.values))
(:report (lambda (c stream) (princ (breakpoint.message c) stream))))
-(defimplementation condition-extras ((c breakpoint))
- ;; simply pop up the source buffer
- `((:short-frame-source 0)))
+(defimplementation condition-extras (condition)
+ (typecase condition
+ (breakpoint
+ ;; pop up the source buffer
+ `((:short-frame-source 0)))
+ (t '())))
(defun signal-breakpoint (breakpoint frame)
"Signal a breakpoint condition for BREAKPOINT in FRAME.
@@ -1817,7 +1865,7 @@
:key #'symbol-value)))
(format t ", type: ~A" type-symbol))))))
-(defimplementation inspect-for-emacs ((o t) (inspector cmucl-inspector))
+(defmethod inspect-for-emacs ((o t) (inspector cmucl-inspector))
(cond ((di::indirect-value-cell-p o)
(values (format nil "~A is a value cell." o)
`("Value: " (:value ,(c:value-cell-ref o)))))
@@ -1835,7 +1883,7 @@
(loop for value in parts for i from 0
append (label-value-line i value))))))
-(defmethod inspect-for-emacs :around ((o function) (inspector cmucl-inspector))
+(defmethod inspect-for-emacs ((o function) (inspector cmucl-inspector))
(declare (ignore inspector))
(let ((header (kernel:get-type o)))
(cond ((= header vm:function-header-type)
@@ -1863,6 +1911,16 @@
(t
(call-next-method)))))
+(defmethod inspect-for-emacs ((o kernel:funcallable-instance)
+ (i cmucl-inspector))
+ (declare (ignore i))
+ (values
+ (format nil "~A is a funcallable-instance." o)
+ (append (label-value-line*
+ (:function (kernel:%funcallable-instance-function o))
+ (:lexenv (kernel:%funcallable-instance-lexenv o))
+ (:layout (kernel:%funcallable-instance-layout o)))
+ (nth-value 1 (cmucl-inspect o)))))
(defmethod inspect-for-emacs ((o kernel:code-component) (_ cmucl-inspector))
(declare (ignore _))
@@ -1904,21 +1962,23 @@
(defmethod inspect-for-emacs ((o array) (inspector cmucl-inspector))
inspector
- (values (format nil "~A is an array." o)
- (label-value-line*
- (:header (describe-primitive-type o))
- (:rank (array-rank o))
- (:fill-pointer (kernel:%array-fill-pointer o))
- (:fill-pointer-p (kernel:%array-fill-pointer-p o))
- (:elements (kernel:%array-available-elements o))
- (:data (kernel:%array-data-vector o))
- (:displacement (kernel:%array-displacement o))
- (:displaced-p (kernel:%array-displaced-p o))
- (:dimensions (array-dimensions o)))))
+ (if (typep o 'simple-array)
+ (call-next-method)
+ (values (format nil "~A is an array." o)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:rank (array-rank o))
+ (:fill-pointer (kernel:%array-fill-pointer o))
+ (:fill-pointer-p (kernel:%array-fill-pointer-p o))
+ (:elements (kernel:%array-available-elements o))
+ (:data (kernel:%array-data-vector o))
+ (:displacement (kernel:%array-displacement o))
+ (:displaced-p (kernel:%array-displaced-p o))
+ (:dimensions (array-dimensions o))))))
-(defmethod inspect-for-emacs ((o vector) (inspector cmucl-inspector))
+(defmethod inspect-for-emacs ((o simple-vector) (inspector cmucl-inspector))
inspector
- (values (format nil "~A is a vector." o)
+ (values (format nil "~A is a simple-vector." o)
(append
(label-value-line*
(:header (describe-primitive-type o))
@@ -1986,14 +2046,17 @@
#+mp
(progn
- (defimplementation startup-multiprocessing ()
+ (defimplementation initialize-multiprocessing (continuation)
+ (mp::init-multi-processing)
+ (mp:make-process continuation :name "swank")
;; Threads magic: this never returns! But top-level becomes
;; available again.
- (mp::startup-idle-and-top-level-loops))
+ (unless mp::*idle-process*
+ (mp::startup-idle-and-top-level-loops)))
+
+ (defimplementation spawn (fn &key name)
+ (mp:make-process fn :name (or name "Anonymous")))
- (defimplementation spawn (fn &key (name "Anonymous"))
- (mp:make-process fn :name name))
-
(defvar *thread-id-counter* 0)
(defimplementation thread-id (thread)
@@ -2060,12 +2123,10 @@
;;; normal output.
;;;
-(defun swank-sym (name) (find-symbol (string name) :swank))
-(defun sending-safe-p () (symbol-value (swank-sym :*emacs-connection*)))
-
;; this should probably not be here, but where else?
-(defun eval-in-emacs (form nowait)
- (funcall (swank-sym :eval-in-emacs) form nowait))
+(defun background-message (message)
+ (funcall (find-symbol (string :background-message) :swank)
+ message))
(defun print-bytes (nbytes &optional stream)
"Print the number NBYTES to STREAM in KB, MB, or GB units."
@@ -2086,7 +2147,7 @@
(defun generation-stats ()
"Return a string describing the size distribution among the generations."
(let* ((alloc (loop for i below gc-generations
- collect (lisp::gencgc-stats i)))
+ collect (lisp::gencgc-stats i)))
(sum (coerce (reduce #'+ alloc) 'float)))
(format nil "~{~3F~^/~}"
(mapcar (lambda (size) (/ size sum))
@@ -2095,11 +2156,10 @@
(defvar *gc-start-time* 0)
(defun pre-gc-hook (bytes-in-use)
+ (setq *gc-start-time* (get-internal-real-time))
(let ((msg (format nil "[Commencing GC with ~A in use.]"
(print-bytes bytes-in-use))))
- (setq *gc-start-time* (get-internal-real-time))
- (when (sending-safe-p)
- (eval-in-emacs `(slime-background-message "%s" ,msg) t))))
+ (background-message msg)))
(defun post-gc-hook (bytes-retained bytes-freed trigger)
(declare (ignore trigger))
@@ -2111,8 +2171,7 @@
#+gencgc(generation-stats)
#-gencgc""
seconds)))
- (when (sending-safe-p)
- (eval-in-emacs `(slime-background-message "%s" ,msg) t))))
+ (background-message msg)))
(defun install-gc-hooks ()
(setq ext:*gc-notify-before* #'pre-gc-hook)
@@ -2180,6 +2239,11 @@
(t
fspec)))
+;;; Weak datastructures
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-p t args))
+
;; Local Variables:
;; pbook-heading-regexp: "^;;;\\(;+\\)"
;; pbook-commentary-regexp: "^;;;\\($\\|[^;]\\)"
Modified: trunk/thirdparty/emacs/slime/swank-corman.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-corman.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-corman.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -238,10 +238,9 @@
(close socket))
(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix))
- (ecase external-format
- (:iso-latin-1-unix
- (sockets:make-socket-stream (sockets:accept-socket socket)))))
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout external-format))
+ (sockets:make-socket-stream (sockets:accept-socket socket)))
;;; Misc
@@ -366,7 +365,7 @@
(funcall fn)))
(defimplementation swank-compile-file (*compile-filename* load-p
- &optional external-format)
+ external-format)
(declare (ignore external-format))
(with-compilation-hooks ()
(let ((*buffer-name* nil))
@@ -385,6 +384,9 @@
;;;; Inspecting
+;; Hack to make swank.lisp load, at least
+(defclass file-stream ())
+
(defclass corman-inspector (inspector)
())
@@ -397,7 +399,7 @@
collect (funcall callback e)
collect ", ")))
-(defimplementation inspect-for-emacs ((class standard-class)
+(defmethod inspect-for-emacs ((class standard-class)
(inspector corman-inspector))
(declare (ignore inspector))
(values "A class."
@@ -436,7 +438,7 @@
'("#<N/A (class not finalized)>"))
(:newline))))
-(defimplementation inspect-for-emacs ((slot cons) (inspector corman-inspector))
+(defmethod inspect-for-emacs ((slot cons) (inspector corman-inspector))
;; Inspects slot definitions
(declare (ignore corman-inspector))
(if (eq (car slot) :name)
@@ -455,7 +457,7 @@
(:newline)))
(call-next-method)))
-(defimplementation inspect-for-emacs ((pathname pathnames::pathname-internal)
+(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal)
inspector)
(declare (ignore inspector))
(values (if (wild-pathname-p pathname)
@@ -473,7 +475,7 @@
(not (probe-file pathname)))
(label-value-line "Truename" (truename pathname))))))
-(defimplementation inspect-for-emacs ((o t) (inspector corman-inspector))
+(defmethod inspect-for-emacs ((o t) (inspector corman-inspector))
(cond ((cl::structurep o) (inspect-structure o))
(t (call-next-method))))
Modified: trunk/thirdparty/emacs/slime/swank-ecl.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-ecl.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-ecl.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,6 +1,10 @@
-;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-ecl.lisp --- SLIME backend for ECL.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
;;; Administrivia
@@ -15,11 +19,6 @@
:specializer-direct-methods
:compute-applicable-methods-using-classes))
-#+nil
-(ffi:clines "
-#include <unistd.h>
-#include <sys/types.h>")
-
;;;; TCP Server
@@ -45,11 +44,12 @@
(sb-bsd-sockets:socket-close socket))
(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix))
- (assert (eq external-format :iso-latin-1-unix))
- (make-socket-io-stream (accept socket) external-format))
+ &key external-format
+ buffering timeout)
+ (declare (ignore buffering timeout external-format))
+ (make-socket-io-stream (accept socket)))
-(defun make-socket-io-stream (socket external-format)
+(defun make-socket-io-stream (socket)
(sb-bsd-sockets:socket-make-stream socket
:output t
:input t
@@ -121,7 +121,7 @@
(funcall function)))
(defimplementation swank-compile-file (*compile-filename* load-p
- &optional external-format)
+ external-format)
(declare (ignore external-format))
(with-compilation-hooks ()
(let ((*buffer-name* nil))
@@ -164,7 +164,7 @@
(t :not-available)))))
:not-available))
-(defimplementation function-name ((f function))
+(defimplementation function-name (f)
(si:compiled-function-name f))
(defimplementation macroexpand-all (form)
Modified: trunk/thirdparty/emacs/slime/swank-gray.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-gray.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-gray.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -12,72 +12,118 @@
(defclass slime-output-stream (fundamental-character-output-stream)
((output-fn :initarg :output-fn)
- (buffer :initform (make-string 512))
+ (buffer :initform (make-string 8000))
(fill-pointer :initform 0)
- (column :initform 0)))
+ (column :initform 0)
+ (last-flush-time :initform (get-internal-real-time))
+ (lock :initform (make-recursive-lock :name "buffer write lock"))))
(defmethod stream-write-char ((stream slime-output-stream) char)
- (with-slots (buffer fill-pointer column) stream
- (setf (schar buffer fill-pointer) char)
- (incf fill-pointer)
- (incf column)
- (when (char= #\newline char)
- (setf column 0))
- (when (= fill-pointer (length buffer))
- (force-output stream)))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (buffer fill-pointer column) stream
+ (setf (schar buffer fill-pointer) char)
+ (incf fill-pointer)
+ (incf column)
+ (when (char= #\newline char)
+ (setf column 0)
+ (force-output stream))
+ (when (= fill-pointer (length buffer))
+ (finish-output stream)))))
char)
(defmethod stream-line-column ((stream slime-output-stream))
- (slot-value stream 'column))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (slot-value stream 'column))))
(defmethod stream-line-length ((stream slime-output-stream))
75)
+(defmethod stream-finish-output ((stream slime-output-stream))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (buffer fill-pointer output-fn last-flush-time) stream
+ (let ((end fill-pointer))
+ (unless (zerop end)
+ (funcall output-fn (subseq buffer 0 end))
+ (setf fill-pointer 0)))
+ (setf last-flush-time (get-internal-real-time)))))
+ nil)
+
(defmethod stream-force-output ((stream slime-output-stream))
- (with-slots (buffer fill-pointer output-fn) stream
- (let ((end fill-pointer))
- (unless (zerop end)
- (funcall output-fn (subseq buffer 0 end))
- (setf fill-pointer 0))))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (last-flush-time fill-pointer) stream
+ (let ((now (get-internal-real-time)))
+ (when (> (/ (- now last-flush-time)
+ (coerce internal-time-units-per-second 'double-float))
+ 0.2)
+ (finish-output stream))))))
nil)
+(defmethod stream-fresh-line ((stream slime-output-stream))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (column) stream
+ (cond ((zerop column) nil)
+ (t (terpri stream) t))))))
+
(defclass slime-input-stream (fundamental-character-input-stream)
((output-stream :initarg :output-stream)
(input-fn :initarg :input-fn)
- (buffer :initform "") (index :initform 0)))
+ (buffer :initform "") (index :initform 0)
+ (lock :initform (make-lock :name "buffer read lock"))))
(defmethod stream-read-char ((s slime-input-stream))
- (with-slots (buffer index output-stream input-fn) s
- (when (= index (length buffer))
- (when output-stream
- (force-output output-stream))
- (let ((string (funcall input-fn)))
- (cond ((zerop (length string))
- (return-from stream-read-char :eof))
- (t
- (setf buffer string)
- (setf index 0)))))
- (assert (plusp (length buffer)))
- (prog1 (aref buffer index) (incf index))))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index output-stream input-fn) s
+ (when (= index (length buffer))
+ (when output-stream
+ (finish-output output-stream))
+ (let ((string (funcall input-fn)))
+ (cond ((zerop (length string))
+ (return-from stream-read-char :eof))
+ (t
+ (setf buffer string)
+ (setf index 0)))))
+ (assert (plusp (length buffer)))
+ (prog1 (aref buffer index) (incf index))))))
(defmethod stream-listen ((s slime-input-stream))
- (with-slots (buffer index) s
- (< index (length buffer))))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (< index (length buffer))))))
(defmethod stream-unread-char ((s slime-input-stream) char)
- (with-slots (buffer index) s
- (decf index)
- (cond ((eql (aref buffer index) char)
- (setf (aref buffer index) char))
- (t
- (warn "stream-unread-char: ignoring ~S (expected ~S)"
- char (aref buffer index)))))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (decf index)
+ (cond ((eql (aref buffer index) char)
+ (setf (aref buffer index) char))
+ (t
+ (warn "stream-unread-char: ignoring ~S (expected ~S)"
+ char (aref buffer index)))))))
nil)
(defmethod stream-clear-input ((s slime-input-stream))
- (with-slots (buffer index) s
- (setf buffer ""
- index 0))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (setf buffer ""
+ index 0))))
nil)
(defmethod stream-line-column ((s slime-input-stream))
@@ -96,9 +142,12 @@
;; We could make do with either of the two methods below.
(defmethod stream-read-char-no-hang ((s slime-input-stream))
- (with-slots (buffer index) s
- (when (< index (length buffer))
- (prog1 (aref buffer index) (incf index)))))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (when (< index (length buffer))
+ (prog1 (aref buffer index) (incf index)))))))
;; This CLISP extension is what listen_char actually calls. The
;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
Modified: trunk/thirdparty/emacs/slime/swank-lispworks.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-lispworks.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-lispworks.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,4 +1,4 @@
-;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
;;;
@@ -11,20 +11,9 @@
(in-package :swank-backend)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (require "comm"))
+ (require "comm")
+ (import-from :stream *gray-stream-symbols* :swank-backend))
-(import
- '(stream:fundamental-character-output-stream
- stream:stream-write-char
- stream:stream-force-output
- stream:fundamental-character-input-stream
- stream:stream-read-char
- stream:stream-listen
- stream:stream-unread-char
- stream:stream-clear-input
- stream:stream-line-column
- ))
-
(import-swank-mop-symbols :clos '(:slot-definition-documentation
:eql-specializer
:eql-specializer-object
@@ -77,8 +66,8 @@
(comm::close-socket (socket-fd socket)))
(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix))
- (assert (eq external-format :iso-latin-1-unix))
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout external-format))
(let* ((fd (comm::get-fd-from-socket socket)))
(assert (/= fd -1))
(make-instance 'comm:socket-stream :socket fd :direction :io
@@ -90,6 +79,24 @@
(sys::set-signal-handler +sigint+
(make-sigint-handler mp:*current-process*)))
+;;; Coding Systems
+
+(defvar *external-format-to-coding-system*
+ '(((:latin-1 :eol-style :lf)
+ "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
+ ((:latin-1)
+ "latin-1" "iso-latin-1" "iso-8859-1")
+ ((:utf-8) "utf-8")
+ ((:utf-8 :eol-style :lf) "utf-8-unix")
+ ((:euc-jp) "euc-jp")
+ ((:euc-jp :eol-style :lf) "euc-jp-unix")
+ ((:ascii) "us-ascii")
+ ((:ascii :eol-style :lf) "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
;;; Unix signals
(defun sigint-handler ()
@@ -366,9 +373,9 @@
(signal-error-data-base compiler::*error-database* ,location)
(signal-undefined-functions compiler::*unknown-functions* ,location)))))
-(defimplementation swank-compile-file (filename load-p)
+(defimplementation swank-compile-file (filename load-p external-format)
(with-swank-compilation-unit (filename)
- (compile-file filename :load load-p)))
+ (compile-file filename :load load-p :external-format external-format)))
(defvar *within-call-with-compilation-hooks* nil
"Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
@@ -378,7 +385,7 @@
(lw:defadvice (compile-file compile-file-and-collect-notes :around)
(pathname &rest rest)
- (prog1 (apply #'lw:call-next-advice pathname rest)
+ (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
(when *within-call-with-compilation-hooks*
(maphash (lambda (unfun dspecs)
(dolist (dspec dspecs)
@@ -533,18 +540,18 @@
function names like \(SETF GET)."
(or (and (eq (symbol-package symbol)
(load-time-value (find-package :setf)))
- (let ((nregex::*regex-groupings* 0)
- (nregex::*regex-groups* (make-array 10))
+ (let ((slime-nregex::*regex-groupings* 0)
+ (slime-nregex::*regex-groups* (make-array 10))
(symbol-name (symbol-name symbol)))
(and (funcall (load-time-value
- (compile nil (nregex:regex-compile "^\"(.+)\" \"(.+)\"$")))
+ (compile nil (slime-nregex:regex-compile "^\"(.+)\" \"(.+)\"$")))
symbol-name)
(list 'setf
(intern (apply #'subseq symbol-name
- (aref nregex::*regex-groups* 2))
+ (aref slime-nregex::*regex-groups* 2))
(find-package
(apply #'subseq symbol-name
- (aref nregex::*regex-groups* 1))))))))
+ (aref slime-nregex::*regex-groups* 1))))))))
symbol))
(defun signal-undefined-functions (htab &optional filename)
@@ -631,15 +638,22 @@
(defimplementation make-default-inspector ()
(make-instance 'lispworks-inspector))
-(defimplementation inspect-for-emacs ((o t) (inspector lispworks-inspector))
+(defmethod inspect-for-emacs ((o t) (inspector lispworks-inspector))
(declare (ignore inspector))
(lispworks-inspect o))
-(defimplementation inspect-for-emacs ((o function)
- (inspector lispworks-inspector))
+(defmethod inspect-for-emacs ((o function)
+ (inspector lispworks-inspector))
(declare (ignore inspector))
(lispworks-inspect o))
+;; FIXME: slot-boundp-using-class in LW works with names so we can't
+;; use our method in swank.lisp.
+(defmethod inspect-for-emacs ((o standard-object)
+ (inspector lispworks-inspector))
+ (declare (ignore inspector))
+ (lispworks-inspect o))
+
(defun lispworks-inspect (o)
(multiple-value-bind (names values _getter _setter type)
(lw:get-inspector-values o nil)
@@ -677,8 +691,12 @@
;;; Multithreading
-(defimplementation startup-multiprocessing ()
- (mp:initialize-multiprocessing))
+(defimplementation initialize-multiprocessing (continuation)
+ (cond ((not mp::*multiprocessing*)
+ (push (list "Initialize SLIME" '() continuation)
+ mp:*initial-processes*)
+ (mp:initialize-multiprocessing))
+ (t (funcall continuation))))
(defimplementation spawn (fn &key name)
(let ((mp:*process-initial-bindings*
@@ -745,7 +763,7 @@
;;; Some intergration with the lispworks environment
-(defun swank-sym (name) (find-symbol (string name) (string :swank)))
+(defun swank-sym (name) (find-symbol (string name) :swank))
(defimplementation emacs-connected ()
(when (eq (eval (swank-sym :*communication-style*))
@@ -756,8 +774,7 @@
(defmethod env-internals:environment-display-notifier
(env &key restarts condition)
(declare (ignore restarts))
- (funcall (find-symbol (string :swank-debugger-hook) :swank)
- condition *debugger-hook*))
+ (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*))
(defmethod env-internals:environment-display-debugger (env)
*debug-io*)))
@@ -769,6 +786,5 @@
(force-output o)))))
(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
- (let ((prompt (cond (msg (apply #'format nil msg args))
- (t ""))))
- (funcall (swank-sym :eval-in-emacs) `(y-or-n-p ,prompt))))
+ (apply (swank-sym :y-or-n-p-in-emacs) msg args))
+
Modified: trunk/thirdparty/emacs/slime/swank-loader.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-loader.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-loader.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -8,56 +8,78 @@
;;; are disclaimed.
;;;
+;; If you want customize the source- or fasl-directory you can set
+;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
+;; before loading this files. (you also need to create the
+;; swank-loader package.)
+;; E.g.:
+;;
+;; (make-package :swank-loader)
+;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")
+;; (load ".../swank-loader.lisp")
+
+
(cl:defpackage :swank-loader
- (:use :common-lisp))
+ (:use :cl)
+ (:export :load-swank
+ :*source-directory*
+ :*fasl-directory*))
-(in-package :swank-loader)
+(cl:in-package :swank-loader)
-(defun make-swank-pathname (name &optional (type "lisp"))
- "Return a pathname with name component NAME in the Slime directory."
- (merge-pathnames (make-pathname :name name :type type)
- (or *compile-file-pathname*
- *load-pathname*
- *default-pathname-defaults*)))
+(defvar *source-directory*
+ (make-pathname :name nil :type nil
+ :defaults (or *load-pathname* *default-pathname-defaults*))
+ "The directory where to look for the source.")
-(defparameter *sysdep-pathnames*
- (mapcar #'make-swank-pathname
- (append
- '("nregex")
- #+cmu '("swank-source-path-parser" "swank-source-file-cache"
- "swank-cmucl")
- #+sbcl '("swank-sbcl" "swank-source-path-parser"
- "swank-source-file-cache" "swank-gray")
- #+openmcl '("metering" "swank-openmcl" "swank-gray")
- #+lispworks '("swank-lispworks" "swank-gray")
- #+allegro '("swank-allegro" "swank-gray")
- #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
- #+armedbear '("swank-abcl")
- )))
+(defparameter *sysdep-files*
+ (append
+ '("nregex")
+ #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl")
+ #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl")
+ #+sbcl '("swank-sbcl" "swank-source-path-parser"
+ "swank-source-file-cache" "swank-gray")
+ #+openmcl '("metering" "swank-openmcl" "swank-gray")
+ #+lispworks '("swank-lispworks" "swank-gray")
+ #+allegro '("swank-allegro" "swank-gray")
+ #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
+ #+armedbear '("swank-abcl")
+ #+cormanlisp '("swank-corman" "swank-gray")
+ #+ecl '("swank-ecl" "swank-gray")
+ ))
(defparameter *implementation-features*
- '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :armedbear :gcl :ecl))
+ '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
+ :armedbear :gcl :ecl :scl))
(defparameter *os-features*
- '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :unix))
+ '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
+ :unix))
(defparameter *architecture-features*
- '(:powerpc :ppc :x86 :x86-64 :i686 :pc386 :iapx386 :sparc))
+ '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
+ :sparc64 :sparc :hppa64 :hppa))
(defun lisp-version-string ()
- #+cmu (substitute #\- #\/ (lisp-implementation-version))
+ #+cmu (substitute-if #\_ (lambda (x) (find x " /"))
+ (lisp-implementation-version))
+ #+scl (lisp-implementation-version)
#+sbcl (lisp-implementation-version)
#+ecl (lisp-implementation-version)
- #+gcl (let ((s (lisp-implementation-version))) (subseq s 4))
#+openmcl (format nil "~d.~d"
- ccl::*openmcl-major-version*
+ ccl::*openmcl-major-version*
ccl::*openmcl-minor-version*)
#+lispworks (lisp-implementation-version)
- #+allegro excl::*common-lisp-version-number*
+ #+allegro (format nil
+ "~A~A~A"
+ excl::*common-lisp-version-number*
+ (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
+ (if (member :64bit *features*) "-64bit" ""))
#+clisp (let ((s (lisp-implementation-version)))
(subseq s 0 (position #\space s)))
- #+armedbear (lisp-implementation-version))
-
+ #+armedbear (lisp-implementation-version)
+ #+cormanlisp (lisp-implementation-version))
+
(defun unique-directory-name ()
"Return a name that can be used as a directory name that is
unique to a Lisp implementation, Lisp implementation version,
@@ -70,7 +92,7 @@
(t (apply #'warn fstring args)
"unknown"))))
(let ((lisp (maybe-warn (first-of *implementation-features*)
- "No implementation feature found in ~a."
+ "No implementation feature found in ~a."
*implementation-features*))
(os (maybe-warn (first-of *os-features*)
"No os feature found in ~a." *os-features*))
@@ -82,66 +104,106 @@
implementation version.")))
(format nil "~(~@{~a~^-~}~)" lisp version os arch))))
-(defparameter *swank-pathname* (make-swank-pathname "swank"))
-
(defun file-newer-p (new-file old-file)
"Returns true if NEW-FILE is newer than OLD-FILE."
(> (file-write-date new-file) (file-write-date old-file)))
-(defun binary-pathname (source-pathname)
+(defun slime-version-string ()
+ "Return a string identifying the SLIME version.
+Return nil if nothing appropriate is available."
+ (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
+ :if-does-not-exist nil)
+ (and s (symbol-name (read s)))))
+
+(defun default-fasl-directory ()
+ (merge-pathnames
+ (make-pathname
+ :directory `(:relative ".slime" "fasl"
+ ,@(if (slime-version-string) (list (slime-version-string)))
+ ,(unique-directory-name)))
+ (user-homedir-pathname)))
+
+(defun binary-pathname (source-pathname binary-directory)
"Return the pathname where SOURCE-PATHNAME's binary should be compiled."
(let ((cfp (compile-file-pathname source-pathname)))
- (merge-pathnames (make-pathname
- :directory
- `(:relative ".slime" "fasl" ,(unique-directory-name))
- :name (pathname-name cfp)
- :type (pathname-type cfp))
- (user-homedir-pathname))))
+ (merge-pathnames (make-pathname :name (pathname-name cfp)
+ :type (pathname-type cfp))
+ binary-directory)))
-(defun compile-files-if-needed-serially (files)
+
+(defun handle-loadtime-error (condition binary-pathname)
+ (format *error-output*
+ "~%~<;; ~@;Error while loading: ~A~% Condition: ~A~%Aborting.~:>~%"
+ (list binary-pathname condition))
+ (when (equal (directory-namestring binary-pathname)
+ (directory-namestring (default-fasl-directory)))
+ (ignore-errors (delete-file binary-pathname)))
+ (abort))
+
+(defun compile-files-if-needed-serially (files fasl-directory)
"Compile each file in FILES if the source is newer than
-its corresponding binary, or the file preceding it was
+its corresponding binary, or the file preceding it was
recompiled."
(with-compilation-unit ()
(let ((needs-recompile nil))
(dolist (source-pathname files)
- (let ((binary-pathname (binary-pathname source-pathname)))
+ (let ((binary-pathname (binary-pathname source-pathname
+ fasl-directory)))
(handler-case
(progn
(when (or needs-recompile
(not (probe-file binary-pathname))
(file-newer-p source-pathname binary-pathname))
+ ;; need a to recompile source-pathname, so we'll
+ ;; need to recompile everything after this too.
+ (setq needs-recompile t)
(ensure-directories-exist binary-pathname)
(compile-file source-pathname :output-file binary-pathname
- :print nil :verbose t)
- (setq needs-recompile t))
+ :print nil
+ :verbose t))
(load binary-pathname :verbose t))
- #+(or)
- (error ()
- ;; If an error occurs compiling, load the source instead
- ;; so we can try to debug it.
- (load source-pathname))
- ))))))
+ ;; Fail as early as possible
+ (serious-condition (c)
+ (handle-loadtime-error c binary-pathname))))))))
-(compile-files-if-needed-serially
- (append (list (make-swank-pathname "swank-backend"))
- *sysdep-pathnames*
- (list *swank-pathname*)))
+#+(or cormanlisp ecl)
+(defun compile-files-if-needed-serially (files fasl-directory)
+ "Corman Lisp and ECL have trouble with compiled files."
+ (declare (ignore fasl-directory))
+ (dolist (file files)
+ (load file :verbose t)
+ (force-output)))
-(funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
-
(defun load-user-init-file ()
"Load the user init file, return NIL if it does not exist."
(load (merge-pathnames (user-homedir-pathname)
(make-pathname :name ".swank" :type "lisp"))
:if-does-not-exist nil))
-(export 'load-user-init-file)
-(defun load-site-init-file ()
+(defun load-site-init-file (directory)
(load (make-pathname :name "site-init" :type "lisp"
- :defaults *load-truename*)
+ :defaults directory)
:if-does-not-exist nil))
-(or (load-site-init-file)
- (load-user-init-file))
+(defun swank-source-files (source-directory)
+ (mapcar (lambda (name)
+ (make-pathname :name name :type "lisp"
+ :defaults source-directory))
+ `("swank-backend" ,@*sysdep-files* "swank")))
+(defvar *fasl-directory* (default-fasl-directory)
+ "The directory where fasl files should be placed.")
+
+(defun load-swank (&key
+ (source-directory *source-directory*)
+ (fasl-directory *fasl-directory*))
+ (compile-files-if-needed-serially (swank-source-files source-directory)
+ fasl-directory)
+ (set (read-from-string "swank::*swank-wire-protocol-version*")
+ (slime-version-string))
+ (funcall (intern (string :warn-unimplemented-interfaces) :swank-backend))
+ (load-site-init-file source-directory)
+ (load-user-init-file)
+ (funcall (intern (string :run-after-init-hook) :swank)))
+
+(load-swank)
Added: trunk/thirdparty/emacs/slime/swank-loader.x86f
===================================================================
--- trunk/thirdparty/emacs/slime/swank-loader.x86f 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-loader.x86f 2006-11-30 16:32:54 UTC (rev 2092)
@@ -0,0 +1,66 @@
+FASL FILE output from /usr/home/hans/bknr-svn/thirdparty/emacs/slime/swank-loader.lisp.
+Compiled Wednesday, 11/15/06 07:15:22 am GMT on ibuprofen.huebner.org
+Compiler 1.1, Lisp 19c Release (19C)
+Targeted for Intel x86, FASL version 19C
+���Q&KERNEL %DEFPACKAGE& SWANK-LOADER& COMMON-LISP QUOTE QUOTE QUOTE QUOTE QUOTE& COMMON-LISP QUOTE QUOTE QUOTE QUOTE 6RQ %IN-PACKAGE QUOTE& SWANK-LOADER6R?>#�B&lispNNAMENTYPE
MAKE-PATHNAME< *COMPILE-FILE-PATHNAME* MERGE-PATHNAMES< *LOAD-PATHNAME* *DEFAULT-PATHNAME-DEFAULTS*Q&C COMPILED-DEBUG-INFORQR($$-Q&
+EXTENSIONS INSTANCER( $$- Q STRUCTURE-OBJECTR ( $$- Q
+DEBUG-INFOR ("$$-#($$$-%&DEFUN MAKE-SWANK-PATHNAME&& SWANK-LOADER'Q COMPILED-DEBUG-FUNCTIONR Q DEBUG-FUNCTIONR (*$$-+(,$$
--Q& SWANK-LOADERR .MAKE-SWANK-PATHNAMENEXTERNAL+G2MG3�G4��1+& 2$+$3NSTANDARD$'$$ #�1
5$5-&NOPTIONAL+NAME�7+58$+94$'$$5#�1
:$A-/+NAMECTYPE COMMON-LISP�;+EA*<$$
OPTIONAL-ARGS$(>4$'$$A#�1
?(@1AB;
+�~�E��e���t��u�U�}���
+M�U��E�܃���}�5�E�C�� ��k����P��
!�A�=�tH= �(t���%��u��`�
)�A�=�t#= �(t���ԋ-�x����t ���
+N�
+N�
+QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER�rQNABSOLUTER�]QNABSOLUTER�QQNABSOLUTER�HQNABSOLUTER�:=?K/& (name &optional (type "lisp"))L FUNCTION &OPTIONALO PATHNAMEQ�/RJ?>S#B&nregexST&swank-source-path-parserU&swank-source-file-cacheV& swank-cmuclWX APPEND</< .*SYSDEP-PATHNAMES* CONS%& DEFPARAMETER *SYSDEP-PATHNAMES*\'-&Top-Level Form]N TOP-LEVEL+_+P { W `$+a4$'$$ #x1
b(c1de;~ �E��e� �(�4�(� �(� |�(; ��(v�� |�(�[�ÉP��@ �(� �(�=4�(t� ��u��u�܃� ��=���k����P��u�������}��u�V��܃� � ��k����P��u�}��4�(� �(� |�(; ��(v�� |�(�[�ÉP��@ �(� �(�=4�(t� �ˁ� �(t>�_�v��$<u>��= �(�c����E�@�
!�A�� �(�M��E��������%�
+!���
+��QNABSOLUTER�lQNABSOLUTER�OQNRELATIVER�alloc_overflow_ebx�QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER�QNRELATIVER�alloc_overflow_ebxE=?n]&()oM�/R&BReturn a pathname with name component NAME in the Slime directory.q PROCLAIM< SPECIALZt#]1uv;? !"�q#$�q0�w]$$Q SIMPLE-BYTE-FUNCTIONRQ FUNCTIONR(z$$-{Q FUNCALLABLE-INSTANCER{(}$$-~Q BYTE-FUNCTION-OR-CLOSURER{~(�$$-�Q
BYTE-FUNCTIONR{~�(�$$-�(�$$-���8p8LSET-DEFVAR-SOURCE-LOCATION<ZQ FILE-SOURCE-LOCATIONR Q FORM-NUMBERSR (�$$-�(�$$-�$&@/usr/home/hans/bknr-svn/thirdparty/emacs/slime/swank-loader.lisp�1�r<s .*IMPLEMENTATION-FEATURES*�NALLEGRON LISPWORKSNSBCLNOPENMCLNCMUNCLISPNCCLNCORMANN ARMEDBEARNGCLNECL ����$�1�s .
*OS-FEATURES*�NMACOSXNLINUXNWINDOWSN MSWINDOWSNWIN32NSOLARISNDARWINNSUNOSNUNIX ���$�1�#]1��; !"�q#$�q%&� '(�q#)�q*+� +,�q0��]$$���8?>�$]B LISP-IMPLEMENTATION-VERSION<
+SUBSTITUTE<%&DEFUN LISP-VERSION-STRING�'- .LISP-VERSION-STRING0+G0M�+ ;�$+�4$'$$ $X1
�$"-�+�+" �$+�4$'$$"$]1
�(�1��;]~�E��e���u6�ԃ� �1ɉj����P���-��/�� �u��`���
+MQNABSOLUTER�GQNABSOLUTER�)=?��oM SIMPLE-BASE-STRING��J?>�#&B�&&No implementation feature found in ~a.��&No os feature found in ~a.� .*ARCHITECTURE-FEATURES*&$No architecture feature found in ~a.��<&TDon't know how to get Lisp ~
+ implementation version.�&~(~@{~a~^-~}~)� FORMAT<
+*FEATURES* FIND< WARN<&unknown�%&DEFUN UNIQUE-DIRECTORY-NAME�'- .UNIQUE-DIRECTORY-NAME0+G6M�+ ���$+�4$'$$ #�1
�$&-�+VALUE��+f&)�,�+�&+ �3�$+�4$'$$&#�1
�#�- FLET .FIRST-OF��+F� FEATURES���+C�� F ��$+�+�$'$#�# 1
�#M-� .
+MAYBE-WARN��+ ARGS��FSTRINGcVALUEC�+4�M
N " <
�$$$ REST-ARG$(�+�$'$#M# 1
�(�1��;&~�E��e������
�A�=����͋ԃ� �؉J����E���j����P�������4�(� �(� |�(; ��(v�� |�(�[�ÉP��@ �(� �(�=4�(t� �ŋ̃� �q��Q��A����E�%�q�E�
�A�=���͋ԃ� �؉J����E�V�����P�������4�(� �(� |�(; ��(v�� |�(�[�ÉP��@ �(� �(�=4�(t� �ŋ̃� �q� �Q��A����E����E�!�X�����T�ŋ̃� �A����E������!�P�����*�4�(� �(� |�(; ��(v�� |�(�[�ÉP��@ �(� �(�=4�(t� �ŋ̃� �q�%�Q��A����E����E�ԃ� �)1ɉj����P��ŋ̃� �Q�-�Q� �(�A����E���� �(�=1�u�E��E�E�E�E�5��u��`� �(��$<�<�Ë� �(�[�]�V��v��$<�!�u��9�x������e�� �]�=��k����P��]�u��� �(u�� �(u�� �(�e��m�����}� �(���]��A�x�� �(���U���R�E���$<���ˋ�� �(9�t�q��I��$<t��
+N��)��]�Nj�)�S��{��s�� �k����P��]��E�e��m���E����
+M�
+N�
+�
+N�
+�
+�
+�
+��
+���
+�
+�
+�QNABSOLUTER��QNABSOLUTER�_QNABSOLUTER�QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER�sQNABSOLUTER�WQNABSOLUTER�DQNABSOLUTER�5QNRELATIVER�alloc_overflow_ebx�QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER�}QNRELATIVER�alloc_overflow_ebxFQNABSOLUTER�QNABSOLUTER�QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNRELATIVER�alloc_overflow_ebx�QNABSOLUTER�XQNABSOLUTER�KQNABSOLUTER�(=? �oM OR BASE-STRING NULL
��Jr<s�NPOWERPCNPPCNX86NX86-64NI686NPC386NIAPX386NSPARC��<��$�1���&�Return a name that can be used as a directory name that is
+unique to a Lisp implementation, Lisp implementation version,
+operating system, and hardware architecture.s .*SWANK-PATHNAME* /<&swank #]1 ;' !�q"#�$%&�q?'(0�q?)*+�q ,�q-.�/�0�!]$$��"8?>##�B FILE-WRITE-DATE<%&DEFUN FILE-NEWER-P$'- . FILE-NEWER-P0+G0MG1�G2��&+ {'$
++$(4$'$$ #�1
)$)-%+NEW-FILECOLD-FILEc*+4)
++$
++,4$'$$)#�1
-(.1/0;�~�E��e���uu�U�}��܃� �U���k����P��U�܃� �U����k����P����U����� �(u� �(�M��E��������'�(�ꐐ��
+MQNRELATIVERQ&X86 2 GENERIC->R�lQNABSOLUTER�SQNABSOLUTER�3=?6%&(new-file old-file)7M8 MEMBER:;�%<J?>=#�B COMPILE-FILE-PATHNAME<�<NRELATIVE&.slime?&fasl@
PATHNAME-NAME<
PATHNAME-TYPE<N DIRECTORY< USER-HOMEDIR-PATHNAME<<%&DEFUN BINARY-PATHNAMEE'- .BINARY-PATHNAME0+
+G0MG1�G+ �sH$ +I4$'$$ #�1
J$*-F+CFP�SOURCE-PATHNAMECK+:*
+
+� :
L$ +M4$'$$*#�1
N(O1PQ;�~�E��e����i�U�܃� �U���k����P��U�ԃ� �1ɉj����P���= �5!�E��4�(� �(� |�(; ��(v�� |�(�[�ÉP����@��x����@��p����@��M��H��@ �(� �(�=4�(t� �]��܃� �U�%��k����P��U�܃� �U�)��k����P��܃��-�}��51�M�K��
5�K�C�9��k����P��U��ԃ� �=1ɉj����P����U��A��u��`�
+MQNABSOLUTER��QNABSOLUTER�jQNABSOLUTER�MQNABSOLUTER�AQNABSOLUTER�5QNABSOLUTER�,QNABSOLUTER�QNABSOLUTER��QNRELATIVER�alloc_overflow_ebx�QNABSOLUTER�qQNABSOLUTER�kQNABSOLUTER�eQNABSOLUTER�QQNABSOLUTER�4=?`F&(source-pathname)aMbPc�FdJ?>e#` B PARSE-UNKNOWN-TYPE-SPECIFIER< NOTE-UNDEFINED-REFERENCE<L*ABORTED-COMPILATION-UNITS*L*IN-COMPILATION-UNIT* *UNDEFINED-WARNINGS* *COMPILER-ERROR-COUNT* *COMPILER-WARNING-COUNT* *COMPILER-NOTE-COUNT*B PARSE-UNKNOWN-TYPEQ&
+CONDITIONSR n*HANDLER-CLUSTERS*F< ENSURE-DIRECTORIES-EXIST<N OUTPUT-FILENPRINTNVERBOSE COMPILE-FILE< LOAD<
+PROBE-FILE<%<
PRINT-SUMMARY<%&&DEFUN COMPILE-FILES-IF-NEEDED-SERIALLYx'- . COMPILE-FILES-IF-NEEDED-SERIALLY0+ G51CG52cz+$(��{$ +|4$'$$$#8 1
}$b-x0+ G53MG54�~+���$ +�4$'$#�#= 1
�#�-x+ CLISPC�+��$ +�4$'$#�#B 1
�#�-�
G40y�NCLEANUP+�+%�
+�F�$ +�+�$'$#�#B 1
�#
+-y+FILES��+��
+ �� '� �
+ ' RR�r�$ +�+�$'$#
+#G 1
�#�-�
G0y�+@BINARY-PATHNAME�FILES�NEEDS-RECOMPILECSOURCE-PATHNAMEc�+���
+! � C #
+
]
�$ +�+�$'$#�#Q 1
�#�-�
G31y��+�+��)2�$ +�+�$'$#�#[ 1
�(
�1��;` ~ �E��e��M�U��E��� �ŋ́��U��Q�A����E����ЋM��E�������ᐐ����~6�E��e������U�܃� �U���k����P��=���u��`�@�= �(u� �(�e��m��� �P�����O���� �P��Ƌ
!�A�=��)= �(���'�(�4�(� �(�|�(;��(v��|�(���@�H�� �(�=4�(t� �E�� �(� %�
��(�C����
��(�A��Y��S�1ҋ )�
��(�C����
��(�A��Y��S�1ҋ -�
��(�C����
��(�A��Y��S�1ҋ 1�
��(�C����
��(�A��Y��S��'�(� !�
��(�C����
��(�A��Y��S�1ҋ �
��(�C����
��(�A��Y��S��4�(� �(�|�(;��(v��|�(�@� �(�=4�(t� �
9�H��
5�H���4�(� �(� |�(; ��(v�� |�(�[�ÉP��@ �(� �(�=4�(t� �
=�A�=��C�4�(� �(�|�(;��(v��|�(�R� �(�=4�(t� �Z��B� =�
��(�C����
��(�A��Y��S����(�E����(�
��(��(�E��M��U��e��M����(��i�A��E����(�ŋ́��U�A����E�=��E�E�� �(�H����(����(�ŋ́��U��A����E�w������(�B��J��H��B������(���(�B��J��H��B������(���(�B��J��H��B������(���(�B��J��H��B������(���(�B��J��H��B������(���(�B��J��H��B������(���(�B��J��H��B������(�E�e��m���'�(�4�(� �(�|�(;��(v��|�(���@�H�� �(�=4�(t� �E����(�E����(�
��(��(�E��M��U��e��MЋ��(��i�AQ�EЉ��(�ŋ́��U�A����E��;�E�E�� �(�H����(����(�͋ԁ��E��J����E�L����������U�]��M�E��M��U����(�
��(��(�]����(9�t!�B� �t
�J��H��B���9�u���(�͋ԁ��E��J����E���n����E�]��M���U�]��M�E��M��U����(�
��(��(�]����(9�t!�B� �t
�J��H��B���9�u���(�ŋ́��U��A����E�?�&�E�]��M���E� �(�U��r�E��@��E��܃� �U��A��k����P��Uܺ �(�
=�A�=�� �4�(� �(� |�(; ��(v�� |�(�[� �(�=4�(t� �S��C�=�
��(�B����
��(�A��Q��Z��}� �(���܃� �U܋E��k����P��܃� �U��=I�u܋M�C��C� �(�Q�C��C�'�(�U� �k����P���E�'�(�܃� �U܋=Q�'�(�Y� �k����P�㛋��(�B��J��H��B������(�E��@�E��M���$<����= �(�r���� �(�e��m���܃� �U܋]��k����P��� �(uA�'�(= �(������܃� �U��}܋a��k����P��� �(������ ���� �(뽋R�� �x����tK�܃� �e��k����P�� �(�e��m���
+
�
+M�
+�
+N�
+N�
+N�
+N�
+QNABSOLUTER� QNABSOLUTER� QNABSOLUTER��QNABSOLUTER��QNABSOLUTER�)QNABSOLUTER� QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER�~QNRELATIVER�alloc_overflow_ebxWQNABSOLUTER�#QNABSOLUTER�QNRELATIVERQ UNWINDR��QNABSOLUTER��QNRELATIVERQ UNWINDR�bQNABSOLUTER�OQNABSOLUTER��QNABSOLUTER��QNABSOLUTER�~QNRELATIVER�alloc_overflow_eaxQNABSOLUTER�QNABSOLUTER��QNABSOLUTER��QNABSOLUTER�RQNRELATIVER�alloc_overflow_edx+QNABSOLUTER��QNRELATIVER�alloc_overflow_ebx�QNABSOLUTER��QNABSOLUTER��QNRELATIVER�alloc_overflow_eaxuQNABSOLUTER�4QNABSOLUTER�QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNRELATIVER�alloc_overflow_eaxPQNABSOLUTER� QNABSOLUTER�QNRELATIVERQ 2 GENERIC-+R��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER�H=?�x& (lisp::c)�Mb9 %UNDEFINED%���h����y&(files)�Mb ��y�J?>�#�BD<&.swank�<<NIF-DOES-NOT-EXISTu<%&DEFUN LOAD-USER-INIT-FILE�'- .LOAD-USER-INIT-FILE0+G0M�+ ��$+�4$'$$ #�1
�$&-�+�+&5 �$+�4$'$$&#�1
�(�1��; �~�E��e������ԃ� �1ɉj����P��U�܃���=�5 �!�C��%��k����P����܃� �U�)��k����P��=-� �(�1� �u��`�
+MQNABSOLUTER��QNABSOLUTER��QNABSOLUTER��QNABSOLUTER�bQNABSOLUTER�YQNABSOLUTER�SQNABSOLUTER�MQNABSOLUTER�GQNABSOLUTER�-=?��oM����J�< �$ �1�%<&0Returns true if NEW-FILE is newer than OLD-FILE.�Fd&FReturn the pathname where SOURCE-PATHNAME's binary should be compiled.�y�&zCompile each file in FILES if the source is newer than
+its corresponding binary, or the file preceding it was
+recompiled.�y</<&
swank-backend�Z INTERN< STRING<N WARN-UNIMPLEMENTED-INTERFACESN
SWANK-BACKEND FUNCTIONP<��&9Load the user init file, return NIL if it does not exist.#]1;V !"�q?#$%�q?&'(�q?)*+�q,??-.��/�?/剋�q///�/�`/���q?///�q0�?���]$$�� 8Q EXPORT QUOTE .LOAD-USER-INIT-FILE6R?>
#�B *LOAD-TRUENAME*& site-initNDEFAULTS<�u<%&DEFUN LOAD-SITE-INIT-FILE'- .LOAD-SITE-INIT-FILE0+G0M+ s$+4$'$$ #�1
$"-++"L
+$+4$'$$"#�1
(1 ; �~�E��e���un�
�A�=�tc�܃���=�5 �
!�K��
%�K�C�)��k����P��=-� �(�1� �u��`��
+M�
+NQNABSOLUTER��QNABSOLUTER�uQNABSOLUTER�`QNABSOLUTER�TQNABSOLUTER�KQNABSOLUTER�EQNABSOLUTER�?QNABSOLUTER�9QNABSOLUTER�$=?&o��'J'<�<#]1();? !0�q"�`�#�q0�*]$$��+8Q DEBUG-SOURCER (-$$ -.NFILE�"&��0"
+=�1$+@\��k��
�
~Lu\Qo21 345�)5� 5�5��5̣5�Q5�05� 5��5̿5̮5�v5�e5�B?>6@
\ No newline at end of file
Modified: trunk/thirdparty/emacs/slime/swank-openmcl.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-openmcl.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-openmcl.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -52,18 +52,7 @@
(in-package :swank-backend)
-(import
- '(ccl:fundamental-character-output-stream
- ccl:stream-write-char
- ccl:stream-line-length
- ccl:stream-force-output
- ccl:fundamental-character-input-stream
- ccl:stream-read-char
- ccl:stream-listen
- ccl:stream-unread-char
- ccl:stream-clear-input
- ccl:stream-line-column
- ccl:stream-line-length))
+(import-from :ccl *gray-stream-symbols* :swank-backend)
(require 'xref)
@@ -76,6 +65,7 @@
cl:method
cl:standard-class
ccl::eql-specializer
+ openmcl-mop:finalize-inheritance
;; standard-class readers
openmcl-mop:class-default-initargs
openmcl-mop:class-direct-default-initargs
@@ -107,21 +97,60 @@
;; slot readers
openmcl-mop:slot-definition-allocation
ccl::slot-definition-documentation
+ openmcl-mop:slot-value-using-class
openmcl-mop:slot-definition-initargs
openmcl-mop:slot-definition-initform
openmcl-mop:slot-definition-initfunction
openmcl-mop:slot-definition-name
openmcl-mop:slot-definition-type
openmcl-mop:slot-definition-readers
- openmcl-mop:slot-definition-writers))
+ openmcl-mop:slot-definition-writers
+ openmcl-mop:slot-boundp-using-class))
(defun specializer-name (spec)
(etypecase spec
(cons spec)
- ((or structure-class swank-mop:standard-class built-in-class) (swank-mop:class-name spec))
- (swank-mop:eql-specializer `(eql ,(swank-mop:eql-specializer-object spec)))
- ))
+ (class (class-name spec))
+ (ccl::eql-specializer `(eql ,(ccl::eql-specializer-object spec)))))
+(defun swank-mop:compute-applicable-methods-using-classes (gf args)
+ (let* ((methods (ccl::%gf-methods gf))
+ (args-length (length args))
+ (bits (ccl::inner-lfun-bits gf))
+ arg-count res)
+ (when methods
+ (setq arg-count (length (ccl::%method-specializers (car methods))))
+ (unless (<= arg-count args-length)
+ (error "Too few args to ~s" gf))
+ (unless (or (logbitp ccl::$lfbits-rest-bit bits)
+ (logbitp ccl::$lfbits-restv-bit bits)
+ (logbitp ccl::$lfbits-keys-bit bits)
+ (<= args-length
+ (+ (ldb ccl::$lfbits-numreq bits) (ldb ccl::$lfbits-numopt bits))))
+ (error "Too many args to ~s" gf))
+ (let ((cpls (make-list arg-count)))
+ (declare (dynamic-extent cpls))
+ (do* ((args-tail args (cdr args-tail))
+ (cpls-tail cpls (cdr cpls-tail)))
+ ((null cpls-tail))
+ (setf (car cpls-tail)
+ (ccl::%class-precedence-list (car args-tail))))
+ (flet ((%method-applicable-p (method args cpls)
+ (do* ((specs (ccl::%method-specializers method) (ccl::%cdr specs))
+ (args args (ccl::%cdr args))
+ (cpls cpls (ccl::%cdr cpls)))
+ ((null specs) t)
+ (let ((spec (ccl::%car specs)))
+ (if (typep spec 'ccl::eql-specializer)
+ (unless (subtypep (ccl::%car args) (class-of (ccl::eql-specializer-object spec)))
+ (return nil))
+ (unless (ccl:memq spec (ccl::%car cpls))
+ (return nil)))))))
+ (dolist (m methods)
+ (if (%method-applicable-p m args cpls)
+ (push m res))))
+ (ccl::sort-methods res cpls (ccl::%gf-precedence-list gf))))))
+
;;; TCP Server
(defimplementation preferred-communication-style ()
@@ -137,20 +166,19 @@
(defimplementation close-socket (socket)
(close socket))
-(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix))
- (assert (eq external-format :iso-latin-1-unix))
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout external-format))
(ccl:accept-connection socket :wait t))
(defimplementation emacs-connected ()
(setq ccl::*interactive-abort-process* ccl::*current-process*))
(defimplementation make-stream-interactive (stream)
- nil)
+ (typecase stream
+ (ccl:fundamental-output-stream
+ (push stream ccl::*auto-flush-streams*))))
-(defmethod make-stream-interactive ((stream ccl:fundamental-output-stream))
- (push stream ccl::*auto-flush-streams*))
-
;;; Unix signals
(defimplementation call-without-interrupts (fn)
@@ -216,10 +244,13 @@
;;; Evaluation
-(defimplementation arglist ((fname symbol))
- (ccl:arglist fname))
+(defimplementation arglist (fname)
+ (arglist% fname))
-(defmethod arglist ((f function))
+(defmethod arglist% ((f symbol))
+ (ccl:arglist f))
+
+(defmethod arglist% ((f function))
(ccl:arglist (ccl:function-name f)))
(defimplementation function-name (function)
@@ -234,8 +265,10 @@
"Return the position in the source file of a compiler condition."
(+ 1
(or *buffer-offset* 0)
- (ccl::compiler-warning-stream-position condition)))
+ ;; alanr sometimes returned stream position nil.
+ (or (ccl::compiler-warning-stream-position condition) 0)))
+
(defun handle-compiler-warning (condition)
"Construct a compiler note for Emacs from a compiler warning
condition."
@@ -250,38 +283,41 @@
(make-location
(list :buffer *buffer-name*)
(list :position position t))
- (make-location
- (list :file (ccl::compiler-warning-file-name condition))
- (list :position position t)))))))
+ (if (ccl::compiler-warning-file-name condition)
+ (make-location
+ (list :file (namestring (truename (ccl::compiler-warning-file-name condition))))
+ (list :position position t))))))))
(defun temp-file-name ()
"Return a temporary file name to compile strings into."
(ccl:%get-cstring (#_tmpnam (ccl:%null-ptr))))
(defimplementation call-with-compilation-hooks (function)
- (handler-bind ((ccl::compiler-warning #'handle-compiler-warning))
+ (handler-bind ((ccl::compiler-warning 'handle-compiler-warning))
(funcall function)))
-(defimplementation swank-compile-file (filename load-p)
+(defimplementation swank-compile-file (filename load-p external-format)
+ (declare (ignore external-format))
(with-compilation-hooks ()
(let ((*buffer-name* nil)
(*buffer-offset* nil))
(compile-file filename :load load-p))))
(defimplementation frame-var-value (frame var)
- (map-backtrace
- #'(lambda(frame-number p context lfun pc)
- (when (= frame frame-number)
- (return-from frame-var-value
- (multiple-value-bind (total vsp parent-vsp)
- (ccl::count-values-in-frame p context)
- (loop for count below total
- with varcount = -1
- for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp))
- when name do (incf varcount)
- until (= varcount var)
- finally (return value))
- ))))))
+ (block frame-var-value
+ (map-backtrace
+ #'(lambda(frame-number p context lfun pc)
+ (when (= frame frame-number)
+ (return-from frame-var-value
+ (multiple-value-bind (total vsp parent-vsp)
+ (ccl::count-values-in-frame p context)
+ (loop for count below total
+ with varcount = -1
+ for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp))
+ when name do (incf varcount)
+ until (= varcount var)
+ finally (return value))
+ )))))))
(defun xref-locations (relation name &optional (inverse nil))
(loop for xref in (if inverse
@@ -430,7 +466,15 @@
(ccl::frame-supplied-args p lfun pc nil context)
(declare (ignore count nclosed))
(let ((result nil))
- (loop for var in args
+ (loop named loop
+ for var = (cond
+ ((null args)
+ (return-from loop))
+ ((atom args)
+ (prog1
+ args
+ (setf args nil)))
+ (t (pop args)))
for type in types
for name in names
do
@@ -465,45 +509,46 @@
(princ frame stream))
(defimplementation frame-locals (index)
- (map-backtrace
- (lambda (frame-number p context lfun pc)
- (when (= frame-number index)
- (multiple-value-bind (count vsp parent-vsp)
- (ccl::count-values-in-frame p context)
- (let (result)
- (dotimes (i count)
- (multiple-value-bind (var type name)
- (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp)
- (declare (ignore type))
- (when name
- (push (list
- :name name
- :id 0
- :value var)
- result))))
- (return-from frame-locals (nreverse result))))))))
+ (block frame-locals
+ (map-backtrace
+ (lambda (frame-number p context lfun pc)
+ (when (= frame-number index)
+ (multiple-value-bind (count vsp parent-vsp)
+ (ccl::count-values-in-frame p context)
+ (let (result)
+ (dotimes (i count)
+ (multiple-value-bind (var type name)
+ (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp)
+ (declare (ignore type))
+ (when name
+ (push (list
+ :name name
+ :id 0
+ :value var)
+ result))))
+ (return-from frame-locals (nreverse result)))))))))
(defimplementation frame-catch-tags (index &aux my-frame)
- (map-backtrace
- (lambda (frame-number p context lfun pc)
- (declare (ignore pc lfun))
- (if (= frame-number index)
- (setq my-frame p)
- (when my-frame
- (return-from frame-catch-tags
- (loop for catch = (ccl::%catch-top (ccl::%current-tcr)) then (ccl::next-catch catch)
- while catch
- for csp = (ccl::uvref catch 3) ; ppc32::catch-frame.csp-cell) defined in arch.lisp
- for tag = (ccl::uvref catch 0) ; ppc32::catch-frame.catch-tag-cell)
- until (ccl::%stack< p csp context)
- do (print "-") (print catch) (terpri) (describe tag)
- when (ccl::%stack< my-frame csp context)
- collect (cond
- ((symbolp tag)
- tag)
- ((and (listp tag)
- (typep (car tag) 'restart))
- `(:restart ,(restart-name (car tag))))))))))))
+ (block frame-catch-tags
+ (map-backtrace
+ (lambda (frame-number p context lfun pc)
+ (declare (ignore pc lfun))
+ (if (= frame-number index)
+ (setq my-frame p)
+ (when my-frame
+ (return-from frame-catch-tags
+ (loop for catch = (ccl::%catch-top (ccl::%current-tcr)) then (ccl::next-catch catch)
+ while catch
+ for csp = (ccl::uvref catch 3) ; ppc32::catch-frame.csp-cell) defined in arch.lisp
+ for tag = (ccl::uvref catch 0) ; ppc32::catch-frame.catch-tag-cell)
+ until (ccl::%stack< p csp context)
+ when (ccl::%stack< my-frame csp context)
+ collect (cond
+ ((symbolp tag)
+ tag)
+ ((and (listp tag)
+ (typep (car tag) 'restart))
+ `(:restart ,(restart-name (car tag)))))))))))))
(defimplementation disassemble-frame (the-frame-number)
(let ((function-to-disassemble nil))
@@ -551,7 +596,7 @@
(defun function-source-location (function)
(multiple-value-bind (info name) (ccl::edit-definition-p function)
- (cond ((not info) (list :error "No source info available for ~A" function))
+ (cond ((not info) (list :error (format nil "No source info available for ~A" function)))
((typep (caar info) 'ccl::method)
`(:location
(:file ,(remove-filename-quoting (namestring (translate-logical-pathname (cdr (car info))) )))
@@ -568,32 +613,34 @@
function in a debugger frame. In OpenMCL, we are not able to
find the precise position of the frame, but we do attempt to give
at least the filename containing it."
- (map-backtrace
- (lambda (frame-number p context lfun pc)
- (declare (ignore p context pc))
- (when (and (= frame-number index) lfun)
- (return-from frame-source-location-for-emacs
- (function-source-location lfun))))))
+ (block frame-source-location-for-emacs
+ (map-backtrace
+ (lambda (frame-number p context lfun pc)
+ (declare (ignore p context pc))
+ (when (and (= frame-number index) lfun)
+ (return-from frame-source-location-for-emacs
+ (function-source-location lfun)))))))
(defimplementation eval-in-frame (form index)
- (map-backtrace
- (lambda (frame-number p context lfun pc)
- (when (= frame-number index)
- (multiple-value-bind (count vsp parent-vsp)
- (ccl::count-values-in-frame p context)
- (let ((bindings nil))
- (dotimes (i count)
- (multiple-value-bind (var type name)
- (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp)
- (declare (ignore type))
- (when name
- (push (list name `',var) bindings))
- ))
- (return-from eval-in-frame
- (eval `(let ,bindings
- (declare (ignorable ,@(mapcar 'car bindings)))
- ,form)))
- ))))))
+ (block eval-in-frame
+ (map-backtrace
+ (lambda (frame-number p context lfun pc)
+ (when (= frame-number index)
+ (multiple-value-bind (count vsp parent-vsp)
+ (ccl::count-values-in-frame p context)
+ (let ((bindings nil))
+ (dotimes (i count)
+ (multiple-value-bind (var type name)
+ (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp)
+ (declare (ignore type))
+ (when name
+ (push (list name `',var) bindings))
+ ))
+ (return-from eval-in-frame
+ (eval `(let ,bindings
+ (declare (ignorable ,@(mapcar 'car bindings)))
+ ,form)))
+ )))))))
(defimplementation return-from-frame (index form)
(let ((values (multiple-value-list (eval-in-frame form index))))
@@ -643,6 +690,23 @@
(:class
(describe (find-class symbol)))))
+(defimplementation toggle-trace (spec)
+ "We currently ignore just about everything."
+ (ecase (car spec)
+ (setf
+ (ccl::%trace spec))
+ (:defmethod
+ (ccl::%trace (second spec)))
+ (:defgeneric
+ (ccl::%trace (second spec)))
+ (:call
+ (toggle-trace (third spec)))
+ ;; mb: FIXME: shouldn't we warn that we're not doing anything for
+ ;; these two?
+ (:labels nil)
+ (:flet nil))
+ t)
+
;;; XREF
(defimplementation list-callers (symbol)
@@ -675,13 +739,13 @@
(defimplementation make-default-inspector ()
(make-instance 'openmcl-inspector))
-(defmethod describe-primitive-type (thing)
+(defimplementation describe-primitive-type (thing)
(let ((typecode (ccl::typecode thing)))
(if (gethash typecode *value2tag*)
(string (gethash typecode *value2tag*))
(string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm))))))
-(defimplementation inspect-for-emacs ((o t) (inspector openmcl-inspector))
+(defmethod inspect-for-emacs ((o t) (inspector openmcl-inspector))
(declare (ignore inspector))
(let* ((i (inspector::make-inspector o))
(count (inspector::compute-line-count i))
@@ -730,6 +794,38 @@
collect `(:value ,(ccl::uvref object index))
collect `(:newline)))))
+(defun closure-closed-over-values (closure)
+ (let ((howmany (nth-value 8 (ccl::function-args (ccl::closure-function closure)))))
+ (loop for n below howmany
+ collect
+ (let* ((value (ccl::%svref closure (+ 1 (- howmany n))))
+ (map (car (ccl::function-symbol-map (ccl::closure-function closure))))
+ (label (or (and map (svref map n)) n))
+ (cellp (ccl::closed-over-value-p value)))
+ (list label (if cellp (ccl::closed-over-value value) value))))))
+
+(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure) (inspector t))
+ (declare (ignore inspector))
+ (values
+ (format nil "A closure: ~a" c)
+ `(,@(if (arglist c)
+ (list "Its argument list is: "
+ (funcall (intern "INSPECTOR-PRINC" 'swank) (arglist c)))
+ ;; FIXME inspector-princ should load earlier
+ (list "A function of no arguments"))
+ (:newline)
+ ,@(when (documentation c t)
+ `("Documentation:" (:newline) ,(documentation c t) (:newline)))
+ ,(format nil "Closed over ~a values" (length (closure-closed-over-values c)))
+ (:newline)
+ ,@(loop for (name value) in (closure-closed-over-values c)
+ for count from 1
+ append
+ (label-value-line* ((format nil "~2,' d) ~a" count (string name)) value))))))
+
+
+
+
;;; Multiprocessing
(defvar *known-processes* '() ; FIXME: leakage. -luke
@@ -746,8 +842,6 @@
(defimplementation spawn (fn &key name)
(ccl:process-run-function (or name "Anonymous (Swank)") fn))
-(defimplementation startup-multiprocessing ())
-
(defimplementation thread-id (thread)
(ccl::process-serial-number thread))
@@ -827,3 +921,12 @@
(defimplementation quit-lisp ()
(ccl::quit))
+
+;;; Weak datastructures
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak :key args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ (apply #'make-hash-table :weak :value args))
+
Modified: trunk/thirdparty/emacs/slime/swank-sbcl.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-sbcl.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-sbcl.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -4,49 +4,56 @@
;;;
;;; Created 2003, Daniel Barlow <dan(a)metacircles.com>
;;;
-;;; This code has been placed in the Public Domain. All warranties are
+;;; This code has been placed in the Public Domain. All warranties are
;;; disclaimed.
;;; Requires the SB-INTROSPECT contrib.
;;; Administrivia
+(in-package :swank-backend)
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sb-bsd-sockets)
(require 'sb-introspect)
(require 'sb-posix))
-(in-package :swank-backend)
-(declaim (optimize (debug 2)))
+(declaim (optimize (debug 2) (sb-c:insert-step-conditions 0)))
-(import
- '(sb-gray:fundamental-character-output-stream
- sb-gray:stream-write-char
- sb-gray:stream-line-length
- sb-gray:stream-force-output
- sb-gray:fundamental-character-input-stream
- sb-gray:stream-read-char
- sb-gray:stream-listen
- sb-gray:stream-unread-char
- sb-gray:stream-clear-input
- sb-gray:stream-line-column
- sb-gray:stream-line-length))
+(import-from :sb-gray *gray-stream-symbols* :swank-backend)
+;;; backwards compability tests
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; Generate a form suitable for testing for stepper support (0.9.17)
+ ;; with #+.
+ (defun sbcl-with-new-stepper-p ()
+ (if (find-symbol "ENABLE-STEPPING" "SB-IMPL")
+ '(and)
+ '(or)))
+ ;; Ditto for weak hash-tables
+ (defun sbcl-with-weak-hash-tables ()
+ (if (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT")
+ '(and)
+ '(or))))
+
;;; swank-mop
(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
(defun swank-mop:slot-definition-documentation (slot)
- (sb-pcl::documentation slot t))
+ (sb-pcl::documentation slot t))
;;; TCP Server
(defimplementation preferred-communication-style ()
- (if (and (member :sb-thread *features*)
- (not (sb-alien:extern-alien "linux_no_threads_p" sb-alien:boolean)))
- :spawn
- :fd-handler))
-
+ (cond
+ ;; fixme: when SBCL/win32 gains better select() support, remove
+ ;; this.
+ ((member :win32 *features*) nil)
+ ((member :sb-thread *features*) :spawn)
+ (t :fd-handler)))
+
(defun resolve-hostname (name)
(car (sb-bsd-sockets:host-ent-addresses
(sb-bsd-sockets:get-host-by-name name))))
@@ -67,9 +74,13 @@
(sb-sys:invalidate-descriptor (socket-fd socket))
(sb-bsd-sockets:socket-close socket))
-(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix))
- (make-socket-io-stream (accept socket) external-format))
+(defimplementation accept-connection (socket &key
+ external-format
+ buffering timeout)
+ (declare (ignore timeout))
+ (make-socket-io-stream (accept socket)
+ (or external-format :iso-latin-1-unix)
+ (or buffering :full)))
(defvar *sigio-handlers* '()
"List of (key . fn) pairs to be called on SIGIO.")
@@ -98,14 +109,14 @@
(defimplementation remove-sigio-handlers (socket)
(let ((fd (socket-fd socket)))
(setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
- (sb-sys:invalidate-descriptor fd))
+ (sb-sys:invalidate-descriptor fd))
(close socket))
(defimplementation add-fd-handler (socket fn)
(declare (type function fn))
(let ((fd (socket-fd socket)))
(format *debug-io* "; Adding fd handler: ~S ~%" fd)
- (sb-sys:add-fd-handler fd :input (lambda (_)
+ (sb-sys:add-fd-handler fd :input (lambda (_)
_
(funcall fn)))))
@@ -118,26 +129,35 @@
(sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
(file-stream (sb-sys:fd-stream-fd socket))))
-(defun make-socket-io-stream (socket external-format)
- (let ((encoding (ecase external-format
- (:iso-latin-1-unix :iso-8859-1)
- #+sb-unicode
- (:utf-8-unix :utf-8))))
- (sb-bsd-sockets:socket-make-stream socket
- :output t
- :input t
- :element-type 'character
- #+sb-unicode :external-format
- #+sb-unicode encoding
- )))
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")
+ (:euc-jp "euc-jp" "euc-jp-unix")
+ (:us-ascii "us-ascii" "us-ascii-unix")))
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defun make-socket-io-stream (socket external-format buffering)
+ (sb-bsd-sockets:socket-make-stream socket
+ :output t
+ :input t
+ :element-type 'character
+ :buffering buffering
+ #+sb-unicode :external-format
+ #+sb-unicode external-format
+ ))
+
(defun accept (socket)
"Like socket-accept, but retry on EAGAIN."
- (loop (handler-case
+ (loop (handler-case
(return (sb-bsd-sockets:socket-accept socket))
(sb-bsd-sockets:interrupted-error ()))))
-(defmethod call-without-interrupts (fn)
+(defimplementation call-without-interrupts (fn)
(declare (type function fn))
(sb-sys:without-interrupts (funcall fn)))
@@ -189,9 +209,9 @@
(read stream t nil t))))
(values))
-(defvar *shebang-readtable*
+(defvar *shebang-readtable*
(let ((*readtable* (copy-readtable nil)))
- (set-dispatch-macro-character #\# #\!
+ (set-dispatch-macro-character #\# #\!
(lambda (s c n) (shebang-reader s c n))
*readtable*)
*readtable*))
@@ -215,7 +235,7 @@
(defvar *debootstrap-packages* t)
(defun call-with-debootstrapping (fun)
- (handler-bind ((sb-int:bootstrap-package-not-found
+ (handler-bind ((sb-int:bootstrap-package-not-found
#'sb-int:debootstrap-package))
(funcall fun)))
@@ -223,7 +243,7 @@
`(call-with-debootstrapping (lambda () ,@body)))
(defimplementation call-with-syntax-hooks (fn)
- (cond ((and *debootstrap-packages*
+ (cond ((and *debootstrap-packages*
(sbcl-package-p *package*))
(with-debootstrapping (funcall fn)))
(t
@@ -236,10 +256,11 @@
;;; Utilities
-(defimplementation arglist ((fname t))
+(defimplementation arglist (fname)
(sb-introspect:function-arglist fname))
-(defimplementation function-name ((f function))
+(defimplementation function-name (f)
+ (check-type f function)
(sb-impl::%fun-name f))
(defvar *buffer-name* nil)
@@ -290,7 +311,7 @@
(list :error "No error location available")))
(defun locate-compiler-note (file source-path source)
- (cond ((and (pathnamep file) *buffer-name*)
+ (cond ((and (not (eq file :lisp)) *buffer-name*)
;; Compiling from a buffer
(let ((position (+ *buffer-offset*
(source-path-string-position
@@ -301,14 +322,14 @@
;; Compiling from a file
(make-location (list :file (namestring file))
(list :position
- (1+ (source-path-file-position
+ (1+ (source-path-file-position
source-path file)))))
((and (eq file :lisp) (stringp source))
;; Compiling macro generated code
(make-location (list :source-form source)
(list :position 1)))
(t
- (error "unhandled case"))))
+ (error "unhandled case in compiler note ~S ~S ~S" file source-path source))))
(defun brief-compiler-message-for-emacs (condition)
"Briefly describe a compiler error for Emacs.
@@ -357,10 +378,11 @@
(defvar *trap-load-time-warnings* nil)
-(defimplementation swank-compile-file (filename load-p)
+(defimplementation swank-compile-file (filename load-p external-format)
(handler-case
(let ((output-file (with-compilation-hooks ()
- (compile-file filename))))
+ (compile-file filename
+ :external-format external-format))))
(when output-file
;; Cache the latest source file for definition-finding.
(source-cache-get filename (file-write-date filename))
@@ -370,245 +392,169 @@
;;;; compile-string
-;;; We patch sb-c::debug-source-for-info so that we can dump our own
-;;; bits of source info. Our *user-source-info* is stored in the
-;;; debug-source-info slot.
+;;; We copy the string to a temporary file in order to get adequate
+;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
+;;; which the previous approach using
+;;; (compile nil `(lambda () ,(read-from-string string)))
+;;; did not provide.
-(defvar *real-debug-source-for-info*)
-(defvar *user-source-info*)
-
-(defun debug-source-for-info-advice (info)
- (destructuring-bind (source) (funcall *real-debug-source-for-info* info)
- (when (boundp '*user-source-info*)
- (setf (sb-c::debug-source-info source) *user-source-info*))
- (list source)))
+(sb-alien:define-alien-routine "tmpnam" sb-alien:c-string
+ (dest (* sb-alien:c-string)))
-(defun install-debug-source-patch ()
- (unless (boundp '*real-debug-source-for-info*)
- (setq *real-debug-source-for-info* #'sb-c::debug-source-for-info))
- (sb-ext:without-package-locks
- (setf (symbol-function 'sb-c::debug-source-for-info)
- #'debug-source-for-info-advice)))
+(defun temp-file-name ()
+ "Return a temporary file name to compile strings into."
+ (concatenate 'string (tmpnam nil) ".lisp"))
(defimplementation swank-compile-string (string &key buffer position directory)
(declare (ignore directory))
- (install-debug-source-patch)
- (call/temp-file
- string
- (lambda (filename)
- (let ((*user-source-info* (list :emacs-buffer buffer :emacs-string string
- :emacs-position position))
- (*buffer-name* buffer)
- (*buffer-offset* position)
- (*buffer-substring* string))
- (let ((fasl (with-compilation-hooks ()
- (compile-file filename))))
- (load fasl)
- (delete-file fasl))))))
+ (let ((*buffer-name* buffer)
+ (*buffer-offset* position)
+ (*buffer-substring* string)
+ (filename (temp-file-name)))
+ (flet ((compile-it (fn)
+ (with-compilation-hooks ()
+ (with-compilation-unit
+ (:source-plist (list :emacs-buffer buffer
+ :emacs-string string
+ :emacs-position position))
+ (funcall fn (compile-file filename))))))
+ (with-open-file (s filename :direction :output :if-exists :error)
+ (write-string string s))
+ (unwind-protect
+ (if *trap-load-time-warnings*
+ (compile-it #'load)
+ (load (compile-it #'identity)))
+ (ignore-errors
+ (delete-file filename)
+ (delete-file (compile-file-pathname filename)))))))
-(defun call/temp-file (string fun)
- (let ((filename (temp-file-name)))
- (unwind-protect
- (with-open-file (s filename :direction :output :if-exists :error)
- (write-string string s)
- (finish-output s)
- (funcall fun filename))
- (when (probe-file filename)
- (delete-file filename)))))
-
-(defun temp-file-name ()
- "Return a temporary file name to compile strings into."
- (sb-alien:alien-funcall
- (sb-alien:extern-alien
- "tmpnam"
- (function sb-alien:c-string sb-alien:system-area-pointer))
- (sb-sys:int-sap 0)))
-
;;;; Definitions
(defvar *debug-definition-finding* nil
"When true don't handle errors while looking for definitions.
This is useful when debugging the definition-finding code.")
+(defparameter *definition-types*
+ '(:variable defvar
+ :constant defconstant
+ :type deftype
+ :symbol-macro define-symbol-macro
+ :macro defmacro
+ :compiler-macro define-compiler-macro
+ :function defun
+ :generic-function defgeneric
+ :method defmethod
+ :setf-expander define-setf-expander
+ :structure defstruct
+ :condition define-condition
+ :class defclass
+ :method-combination define-method-combination
+ :package defpackage
+ :transform :deftransform
+ :optimizer :defoptimizer
+ :vop :define-vop
+ :source-transform :define-source-transform)
+ "Map SB-INTROSPECT definition type names to Slime-friendly forms")
+
(defimplementation find-definitions (name)
- (append (function-definitions name)
- (compiler-definitions name)))
+ (loop for type in *definition-types* by #'cddr
+ for locations = (sb-introspect:find-definition-sources-by-name
+ name type)
+ append (loop for source-location in locations collect
+ (make-source-location-specification type name
+ source-location))))
-;;;;; Function definitions
+(defun make-source-location-specification (type name source-location)
+ (list (list* (getf *definition-types* type)
+ name
+ (sb-introspect::definition-source-description source-location))
+ (if *debug-definition-finding*
+ (make-definition-source-location source-location type name)
+ (handler-case (make-definition-source-location source-location
+ type name)
+ (error (e)
+ (list :error (format nil "Error: ~A" e)))))))
-(defun function-definitions (name)
- (flet ((loc (fn name) (safe-function-source-location fn name)))
- (append
- (cond ((and (symbolp name) (macro-function name))
- (list (list `(defmacro ,name)
- (loc (macro-function name) name))))
- ((fboundp name)
- (let ((fn (fdefinition name)))
- (typecase fn
- (generic-function
- (cons (list `(defgeneric ,name) (loc fn name))
- (method-definitions fn)))
- (t
- (list (list `(function ,name) (loc fn name))))))))
- (when (compiler-macro-function name)
- (list (list `(define-compiler-macro ,name)
- (loc (compiler-macro-function name) name)))))))
+(defun make-definition-source-location (definition-source type name)
+ (with-struct (sb-introspect::definition-source-
+ pathname form-path character-offset plist
+ file-write-date)
+ definition-source
+ (destructuring-bind (&key emacs-buffer emacs-position
+ emacs-string &allow-other-keys)
+ plist
+ (cond
+ (emacs-buffer
+ (let ((pos (if form-path
+ (with-debootstrapping
+ (source-path-string-position
+ form-path emacs-string))
+ character-offset)))
+ (make-location `(:buffer ,emacs-buffer)
+ `(:position ,(+ pos emacs-position))
+ `(:snippet ,emacs-string))))
+ ((not pathname)
+ `(:error ,(format nil "Source of ~A ~A not found"
+ (string-downcase type) name)))
+ (t
+ (let* ((namestring (namestring (translate-logical-pathname pathname)))
+ (*readtable* (guess-readtable-for-filename namestring))
+ (pos (1+ (with-debootstrapping
+ ;; Some internal functions have no source path
+ ;; or offset available, just the file (why?).
+ ;; In these cases we can at least try to open
+ ;; the right file.
+ (if form-path
+ (source-path-file-position form-path
+ pathname)
+ 0))))
+ (snippet (source-hint-snippet namestring
+ file-write-date pos)))
+ (make-location `(:file ,namestring)
+ `(:position ,pos)
+ `(:snippet ,snippet))))))))
-;;;; function -> soucre location translation
+(defun source-hint-snippet (filename write-date position)
+ (let ((source (get-source-code filename write-date)))
+ (with-input-from-string (s source)
+ (read-snippet s position))))
-;;; Here we try to find the source locations for function objects. We
-;;; have to special case functions which were compiled with C-c C-c.
-;;; For the other functions we used the toplevel form number as
-;;; returned by the sb-introspect package to find the offset in the
-;;; source file. (If the function has debug-blocks, we should search
-;;; the position of the first code-location; for some reason, that
-;;; doesn't seem to work.)
-
(defun function-source-location (function &optional name)
- "Try to find the canonical source location of FUNCTION."
(declare (type function function))
- (if (function-from-emacs-buffer-p function)
- (find-temp-function-source-location function)
- (find-function-source-location function)))
+ (let ((location (sb-introspect:find-definition-source function)))
+ (make-definition-source-location location :function name)))
(defun safe-function-source-location (fun name)
(if *debug-definition-finding*
(function-source-location fun name)
(handler-case (function-source-location fun name)
- (error (e)
+ (error (e)
(list :error (format nil "Error: ~A" e))))))
-(defun find-function-source-location (function)
- (cond #+(or) ;; doesn't work for unknown reasons
- ((function-has-start-location-p function)
- (code-location-source-location (function-start-location function)))
- ((not (function-source-filename function))
- (error "Source filename not recorded for ~A" function))
- (t
- (let* ((pos (function-source-position function))
- (snippet (function-hint-snippet function pos)))
- (make-location `(:file ,(function-source-filename function))
- `(:position ,pos)
- `(:snippet ,snippet))))))
-
-(defun function-source-position (function)
- ;; We only consider the toplevel form number here.
- (let* ((tlf (function-toplevel-form-number function))
- (filename (function-source-filename function))
- (*readtable* (guess-readtable-for-filename filename)))
- (with-debootstrapping
- (source-path-file-position (list tlf) filename))))
-
-(defun function-source-filename (function)
- (ignore-errors
- (namestring
- (truename
- (sb-introspect:definition-source-pathname
- (sb-introspect:find-definition-source function))))))
-
-(defun function-source-write-date (function)
- (definition-source-file-write-date
- (sb-introspect:find-definition-source function)))
-
-(defun function-toplevel-form-number (function)
- (car
- (sb-introspect:definition-source-form-path
- (sb-introspect:find-definition-source function))))
-
-(defun function-hint-snippet (function position)
- (let ((source (get-source-code (function-source-filename function)
- (function-source-write-date function))))
- (with-input-from-string (s source)
- (read-snippet s position))))
-
-(defun function-has-start-location-p (function)
- (ignore-errors (function-start-location function)))
-
-(defun function-start-location (function)
- (let ((dfun (sb-di:fun-debug-fun function)))
- (and dfun (sb-di:debug-fun-start-location dfun))))
-
-(defun find-temp-function-source-location (function)
- (let ((info (function-debug-source-info function)))
- (with-struct (sb-introspect::definition-source-
- form-path character-offset)
- (sb-introspect:find-definition-source function)
- (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info
- (let ((pos (if form-path
- (with-debootstrapping
- (source-path-string-position
- form-path emacs-string))
- character-offset)))
- (make-location `(:buffer ,emacs-buffer)
- `(:position ,(+ pos emacs-position))
- `(:snippet ,emacs-string)))))))
-
-;; FIXME: Symbol doesn't exist in released SBCL (0.8.20) yet.
-(defun definition-source-file-write-date (def)
- (let ((sym (find-symbol "DEFINITION-SOURCE-FILE-WRITE-DATE"
- (find-package "SB-INTROSPECT"))))
- (when sym (funcall sym def))))
-
-(defun method-definitions (gf)
- (let ((methods (sb-mop:generic-function-methods gf))
- (name (sb-mop:generic-function-name gf)))
- (loop for method in methods
- collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
- (method-source-location method)))))
-
-(defun method-source-location (method)
- (safe-function-source-location (or (sb-pcl::method-fast-function method)
- (sb-pcl:method-function method))
- nil))
-
-;;;;; Compiler definitions
-
-(defun compiler-definitions (name)
- (let ((fun-info (sb-int:info :function :info name)))
- (when fun-info
- (append (transform-definitions fun-info name)
- (optimizer-definitions fun-info name)))))
-
-(defun transform-definitions (fun-info name)
- (loop for xform in (sb-c::fun-info-transforms fun-info)
- for loc = (safe-function-source-location
- (sb-c::transform-function xform) name)
- for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform))
- for note = (sb-c::transform-note xform)
- for spec = (if (consp typespec)
- `(sb-c:deftransform ,(second typespec) ,note)
- `(sb-c:deftransform ,note))
- collect `(,spec ,loc)))
-
-(defun optimizer-definitions (fun-info fun-name)
- (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
- (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
- (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
- (sb-c::fun-info-optimizer . sb-c:optimizer))))
- (loop for (reader . name) in otypes
- for fn = (funcall reader fun-info)
- when fn collect `((sb-c:defoptimizer ,name)
- ,(safe-function-source-location fn fun-name)))))
-
(defimplementation describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
(let ((result '()))
- (labels ((doc (kind)
- (or (documentation symbol kind) :not-documented))
- (maybe-push (property value)
- (when value
- (setf result (list* property value result)))))
+ (flet ((doc (kind)
+ (or (documentation symbol kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
(maybe-push
:variable (multiple-value-bind (kind recorded-p)
(sb-int:info :variable :kind symbol)
(declare (ignore kind))
(if (or (boundp symbol) recorded-p)
(doc 'variable))))
+ (when (fboundp symbol)
+ (maybe-push
+ (cond ((macro-function symbol) :macro)
+ ((special-operator-p symbol) :special-operator)
+ ((typep (fdefinition symbol) 'generic-function)
+ :generic-function)
+ (t :function))
+ (doc 'function)))
(maybe-push
- :function (if (fboundp symbol)
- (doc 'function)))
- (maybe-push
:setf (if (or (sb-int:info :setf :inverse symbol)
(sb-int:info :setf :expander symbol))
(doc 'setf)))
@@ -633,12 +579,30 @@
(defimplementation list-callers (symbol)
(let ((fn (fdefinition symbol)))
- (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
+ (sanitize-xrefs
+ (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
(defimplementation list-callees (symbol)
(let ((fn (fdefinition symbol)))
- (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
+ (sanitize-xrefs
+ (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
+(defun sanitize-xrefs (x)
+ (remove-duplicates
+ (remove-if (lambda (f)
+ (member f (ignored-xref-function-names)))
+ x
+ :key #'car)
+ :test (lambda (a b)
+ (and (eq (first a) (first b))
+ (equal (second a) (second b))))))
+
+(defun ignored-xref-function-names ()
+ #-#.(swank-backend::sbcl-with-new-stepper-p)
+ '(nil sb-c::step-form sb-c::step-values)
+ #+#.(swank-backend::sbcl-with-new-stepper-p)
+ '(nil))
+
(defun function-dspec (fn)
"Describe where the function FN was defined.
Return a list of the form (NAME LOCATION)."
@@ -656,20 +620,51 @@
(defvar *sldb-stack-top*)
+(defimplementation install-debugger-globally (function)
+ (setq sb-ext:*invoke-debugger-hook* function))
+
+#+#.(swank-backend::sbcl-with-new-stepper-p)
+(defimplementation condition-extras (condition)
+ (when (typep condition 'sb-impl::step-form-condition)
+ `((:short-frame-source 0))))
+
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(declare (type function debugger-loop-fn))
(let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
(sb-debug:*stack-top-hint* nil))
- (handler-bind ((sb-di:debug-condition
+ (handler-bind ((sb-di:debug-condition
(lambda (condition)
(signal (make-condition
'sldb-condition
:original-condition condition)))))
(funcall debugger-loop-fn))))
+#+#.(swank-backend::sbcl-with-new-stepper-p)
+(progn
+ (defimplementation activate-stepping (frame)
+ (declare (ignore frame))
+ (sb-impl::enable-stepping))
+ (defimplementation sldb-stepper-condition-p (condition)
+ (typep condition 'sb-ext:step-form-condition))
+ (defimplementation sldb-step-into ()
+ (invoke-restart 'sb-ext:step-into))
+ (defimplementation sldb-step-next ()
+ (invoke-restart 'sb-ext:step-next))
+ (defimplementation sldb-step-out ()
+ (invoke-restart 'sb-ext:step-out)))
+
(defimplementation call-with-debugger-hook (hook fun)
- (let ((sb-ext:*invoke-debugger-hook* hook))
- (funcall fun)))
+ (let ((sb-ext:*invoke-debugger-hook* hook)
+ #+#.(swank-backend::sbcl-with-new-stepper-p)
+ (sb-ext:*stepper-hook*
+ (lambda (condition)
+ (typecase condition
+ (sb-ext:step-form-condition
+ (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
+ (sb-impl::invoke-debugger condition)))))))
+ (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
+ (sb-ext:step-condition #'sb-impl::invoke-stepper))
+ (funcall fun))))
(defun nth-frame (index)
(do ((frame *sldb-stack-top* (sb-di:frame-down frame))
@@ -687,26 +682,7 @@
collect f)))
(defimplementation print-frame (frame stream)
- (macrolet ((printer-form ()
- ;; MEGAKLUDGE: As SBCL 0.8.20.1 fixed its debug IO style
- ;; our usage of unexported interfaces came back to haunt
- ;; us. And since we still use the same interfaces it will
- ;; haunt us again.
- (let ((print-sym (find-symbol "PRINT-FRAME-CALL" :sb-debug)))
- (if (fboundp print-sym)
- (let* ((args (sb-introspect:function-arglist print-sym))
- (key-pos (position '&key args)))
- (cond ((eql 2 key-pos)
- `(,print-sym frame stream))
- ((eql 1 key-pos)
- `(let ((*standard-output* stream))
- (,print-sym frame)))
- (t
- (error "*THWAP* SBCL changes internals ~
- again!"))))
- (error "You're in a twisty little maze of unsupported
- SBCL interfaces, all different.")))))
- (printer-form)))
+ (sb-debug::print-frame-call frame stream))
;;;; Code-location -> source-location translation
@@ -717,36 +693,49 @@
;;; source-location of the corresponding function.
(defun code-location-source-location (code-location)
- (let ((dsource (sb-di:code-location-debug-source code-location)))
- (ecase (sb-di:debug-source-from dsource)
- (:file (file-source-location code-location))
- (:lisp (lisp-source-location code-location)))))
+ (let* ((dsource (sb-di:code-location-debug-source code-location))
+ (plist (sb-c::debug-source-plist dsource)))
+ (if (getf plist :emacs-buffer)
+ (emacs-buffer-source-location code-location plist)
+ (ecase (sb-di:debug-source-from dsource)
+ (:file (file-source-location code-location))
+ (:lisp (lisp-source-location code-location))))))
+;;; FIXME: The naming policy of source-location functions is a bit
+;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
+;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
+;;; which returns the source location for a _code-location_.
+;;;
+;;; Maybe these should be named code-location-file-source-location,
+;;; etc, turned into generic functions, or something. In the very
+;;; least the names should indicate the main entry point vs. helper
+;;; status.
+
(defun file-source-location (code-location)
- (cond ((code-location-has-debug-block-info-p code-location)
- (if (code-location-from-emacs-buffer-p code-location)
- (temp-file-source-location code-location)
- (source-file-source-location code-location)))
- (t
- (let ((fun (code-location-debug-fun-fun code-location)))
- (cond (fun (function-source-location fun))
- (t (error "Cannot find source location for: ~A "
- code-location)))))))
+ (if (code-location-has-debug-block-info-p code-location)
+ (source-file-source-location code-location)
+ (fallback-source-location code-location)))
+(defun fallback-source-location (code-location)
+ (let ((fun (code-location-debug-fun-fun code-location)))
+ (cond (fun (function-source-location fun))
+ (t (abort-request "Cannot find source location for: ~A " code-location)))))
+
(defun lisp-source-location (code-location)
- (let ((source (with-output-to-string (*standard-output*)
- (print-code-location-source-form code-location 100))))
+ (let ((source (prin1-to-string
+ (sb-debug::code-location-source-form code-location 100))))
(make-location `(:source-form ,source) '(:position 0))))
-(defun temp-file-source-location (code-location)
- (let ((info (code-location-debug-source-info code-location)))
- (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info
- (let* ((pos (string-source-position code-location emacs-string))
- (snipped (with-input-from-string (s emacs-string)
- (read-snippet s pos))))
- (make-location `(:buffer ,emacs-buffer)
- `(:position ,(+ emacs-position pos))
- `(:snippet ,snipped))))))
+(defun emacs-buffer-source-location (code-location plist)
+ (if (code-location-has-debug-block-info-p code-location)
+ (destructuring-bind (&key emacs-buffer emacs-position emacs-string) plist
+ (let* ((pos (string-source-position code-location emacs-string))
+ (snipped (with-input-from-string (s emacs-string)
+ (read-snippet s pos))))
+ (make-location `(:buffer ,emacs-buffer)
+ `(:position ,(+ emacs-position pos))
+ `(:snippet ,snipped))))
+ (fallback-source-location code-location)))
(defun source-file-source-location (code-location)
(let* ((code-date (code-location-debug-source-created code-location))
@@ -759,38 +748,18 @@
`(:position ,(1+ pos))
`(:snippet ,snippet))))))
-(defun code-location-debug-source-info (code-location)
- (sb-c::debug-source-info (sb-di::code-location-debug-source code-location)))
-
(defun code-location-debug-source-name (code-location)
(sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))
(defun code-location-debug-source-created (code-location)
- (sb-c::debug-source-created
+ (sb-c::debug-source-created
(sb-di::code-location-debug-source code-location)))
(defun code-location-debug-fun-fun (code-location)
(sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
-(defun code-location-from-emacs-buffer-p (code-location)
- (info-from-emacs-buffer-p (code-location-debug-source-info code-location)))
-
-(defun function-from-emacs-buffer-p (function)
- (info-from-emacs-buffer-p (function-debug-source-info function)))
-
-(defun function-debug-source-info (function)
- (let* ((comp (sb-di::compiled-debug-fun-component
- (sb-di::fun-debug-fun function))))
- (sb-c::debug-source-info (car (sb-c::debug-info-source
- (sb-kernel:%code-debug-info comp))))))
-
-(defun info-from-emacs-buffer-p (info)
- (and info
- (consp info)
- (eq :emacs-buffer (car info))))
-
(defun code-location-has-debug-block-info-p (code-location)
- (handler-case
+ (handler-case
(progn (sb-di:code-location-debug-block code-location)
t)
(sb-di:no-debug-blocks () nil)))
@@ -814,38 +783,14 @@
;;; source-path-file-position and friends are in swank-source-path-parser
-(defun print-code-location-source-form (code-location context)
- (macrolet ((printer-form ()
- ;; KLUDGE: These are both unexported interfaces, used
- ;; by different versions of SBCL. ...sooner or later
- ;; this will change again: hopefully by then we have
- ;; figured out the interface we want to drive the
- ;; debugger with and requested it from the SBCL
- ;; folks.
- (let ((print-code-sym
- (find-symbol "PRINT-CODE-LOCATION-SOURCE-FORM"
- :sb-debug))
- (code-sym
- (find-symbol "CODE-LOCATION-SOURCE-FORM"
- :sb-debug)))
- (cond ((fboundp print-code-sym)
- `(,print-code-sym code-location context))
- ((fboundp code-sym)
- `(prin1 (,code-sym code-location context)))
- (t
- (error
- "*THWAP* SBCL changes its debugger interface ~
- again!"))))))
- (printer-form)))
-
(defun safe-source-location-for-emacs (code-location)
(if *debug-definition-finding*
(code-location-source-location code-location)
(handler-case (code-location-source-location code-location)
(error (c) (list :error (format nil "~A" c))))))
-
+
(defimplementation frame-source-location-for-emacs (index)
- (safe-source-location-for-emacs
+ (safe-source-location-for-emacs
(sb-di:frame-code-location (nth-frame index))))
(defun frame-debug-vars (frame)
@@ -877,7 +822,7 @@
(defimplementation eval-in-frame (form index)
(let ((frame (nth-frame index)))
(funcall (the function
- (sb-di:preprocess-for-eval form
+ (sb-di:preprocess-for-eval form
(sb-di:frame-code-location frame)))
frame)))
@@ -892,7 +837,14 @@
(sb-di::frame-catches frame))))
(cond (probe (throw (car probe) (eval-in-frame form index)))
(t (format nil "Cannot return from frame: ~S" frame)))))
-
+
+;; FIXME: this implementation doesn't unwind the stack before
+;; re-invoking the function, but it's better than no implementation at
+;; all.
+(defimplementation restart-frame (index)
+ (let ((frame (nth-frame index)))
+ (return-from-frame index (sb-debug::frame-call-as-list frame))))
+
;;;;; reference-conditions
(defimplementation format-sldb-condition (condition)
@@ -967,26 +919,26 @@
(:code (sb-kernel:fun-code-header o)))))
((= header sb-vm:closure-header-widetag)
(values "A closure."
- (append
+ (append
(label-value-line :function (sb-kernel:%closure-fun o))
`("Closed over values:" (:newline))
(loop for i below (1- (sb-kernel:get-closure-length o))
- append (label-value-line
+ append (label-value-line
i (sb-kernel:%closure-index-ref o i))))))
(t (call-next-method o)))))
(defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
(declare (ignore _))
(values (format nil "~A is a code data-block." o)
- (append
- (label-value-line*
+ (append
+ (label-value-line*
(:code-size (sb-kernel:%code-code-size o))
(:entry-points (sb-kernel:%code-entry-points o))
(:debug-info (sb-kernel:%code-debug-info o))
- (:trace-table-offset (sb-kernel:code-header-ref
+ (:trace-table-offset (sb-kernel:code-header-ref
o sb-vm:code-trace-table-offset-slot)))
`("Constants:" (:newline))
- (loop for i from sb-vm:code-constants-offset
+ (loop for i from sb-vm:code-constants-offset
below (sb-kernel:get-header-data o)
append (label-value-line i (sb-kernel:code-header-ref o i)))
`("Code:" (:newline)
@@ -994,8 +946,8 @@
(cond ((sb-kernel:%code-debug-info o)
(sb-disassem:disassemble-code-component o :stream s))
(t
- (sb-disassem:disassemble-memory
- (sb-disassem::align
+ (sb-disassem:disassemble-memory
+ (sb-disassem::align
(+ (logandc2 (sb-kernel:get-lisp-obj-address o)
sb-vm:lowtag-mask)
(* sb-vm:code-constants-offset
@@ -1004,6 +956,12 @@
(ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
:stream s))))))))
+(defmethod inspect-for-emacs ((o sb-ext:weak-pointer) (inspector sbcl-inspector))
+ (declare (ignore inspector))
+ (values "A weak pointer."
+ (label-value-line*
+ (:value (sb-ext:weak-pointer-value o)))))
+
(defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
(declare (ignore inspector))
(values "A fdefn object."
@@ -1011,12 +969,12 @@
(:name (sb-kernel:fdefn-name o))
(:function (sb-kernel:fdefn-fun o)))))
-(defmethod inspect-for-emacs :around ((o generic-function)
+(defmethod inspect-for-emacs :around ((o generic-function)
(inspector sbcl-inspector))
(declare (ignore inspector))
(multiple-value-bind (title contents) (call-next-method)
(values title
- (append
+ (append
contents
(label-value-line*
(:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
@@ -1026,41 +984,66 @@
;;;; Multiprocessing
-#+sb-thread
+#+(and sb-thread
+ #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
(progn
+ (defvar *thread-id-counter* 0)
+
+ (defvar *thread-id-counter-lock*
+ (sb-thread:make-mutex :name "thread id counter lock"))
+
+ (defun next-thread-id ()
+ (sb-thread:with-mutex (*thread-id-counter-lock*)
+ (incf *thread-id-counter*)))
+
+ (defparameter *thread-id-map* (make-hash-table))
+
+ ;; This should be a thread -> id map but as weak keys are not
+ ;; supported it is id -> map instead.
+ (defvar *thread-id-map-lock*
+ (sb-thread:make-mutex :name "thread id map lock"))
+
(defimplementation spawn (fn &key name)
- (declare (ignore name))
- (sb-thread:make-thread fn))
+ (sb-thread:make-thread fn :name name))
- (defimplementation startup-multiprocessing ())
-
(defimplementation thread-id (thread)
- thread)
+ (block thread-id
+ (sb-thread:with-mutex (*thread-id-map-lock*)
+ (loop for id being the hash-key in *thread-id-map*
+ using (hash-value thread-pointer)
+ do
+ (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
+ (cond ((null maybe-thread)
+ ;; the value is gc'd, remove it manually
+ (remhash id *thread-id-map*))
+ ((eq thread maybe-thread)
+ (return-from thread-id id)))))
+ ;; lazy numbering
+ (let ((id (next-thread-id)))
+ (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
+ id))))
(defimplementation find-thread (id)
- (if (member id (all-threads))
- id))
-
+ (sb-thread:with-mutex (*thread-id-map-lock*)
+ (let ((thread-pointer (gethash id *thread-id-map*)))
+ (if thread-pointer
+ (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
+ (if maybe-thread
+ maybe-thread
+ ;; the value is gc'd, remove it manually
+ (progn
+ (remhash id *thread-id-map*)
+ nil)))
+ nil))))
+
(defimplementation thread-name (thread)
- (format nil "Thread ~D" thread))
+ ;; sometimes the name is not a string (e.g. NIL)
+ (princ-to-string (sb-thread:thread-name thread)))
- (defun %thread-state-slot (thread)
- (sb-sys:without-gcing
- (sb-kernel:make-lisp-obj
- (sb-sys:sap-int
- (sb-sys:sap-ref-sap (sb-thread::thread-sap-from-id thread)
- (* sb-vm::thread-state-slot
- sb-vm::n-word-bytes))))))
-
- (defun %thread-state (thread)
- (ecase (%thread-state-slot thread)
- (0 :running)
- (1 :stopping)
- (2 :stopped)
- (3 :dead)))
-
(defimplementation thread-status (thread)
- (string (%thread-state thread)))
+ (if (sb-thread:thread-alive-p thread)
+ "RUNNING"
+ "STOPPED"))
(defimplementation make-lock (&key name)
(sb-thread:make-mutex :name name))
@@ -1069,17 +1052,19 @@
(declare (type function function))
(sb-thread:with-mutex (lock) (funcall function)))
+ (defimplementation make-recursive-lock (&key name)
+ (sb-thread:make-mutex :name name))
+
+ (defimplementation call-with-recursive-lock-held (lock function)
+ (declare (type function function))
+ (sb-thread:with-recursive-lock (lock) (funcall function)))
+
(defimplementation current-thread ()
- (sb-thread:current-thread-id))
+ sb-thread:*current-thread*)
(defimplementation all-threads ()
- (let ((pids (sb-sys:without-gcing
- (sb-thread::mapcar-threads
- (lambda (sap)
- (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
- sb-vm::thread-pid-slot)))))))
- (remove :dead pids :key #'%thread-state)))
-
+ (sb-thread:list-all-threads))
+
(defimplementation interrupt-thread (thread fn)
(sb-thread:interrupt-thread thread fn))
@@ -1087,13 +1072,13 @@
(sb-thread:terminate-thread thread))
(defimplementation thread-alive-p (thread)
- (ignore-errors (sb-thread:interrupt-thread thread (lambda ())) t))
+ (sb-thread:thread-alive-p thread))
(defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
(defvar *mailboxes* (list))
(declaim (type list *mailboxes*))
- (defstruct (mailbox (:conc-name mailbox.))
+ (defstruct (mailbox (:conc-name mailbox.))
thread
(mutex (sb-thread:make-mutex))
(waitqueue (sb-thread:make-waitqueue))
@@ -1116,7 +1101,7 @@
(sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
(defimplementation receive ()
- (let* ((mbox (mailbox (sb-thread:current-thread-id)))
+ (let* ((mbox (mailbox (current-thread)))
(mutex (mailbox.mutex mbox)))
(sb-thread:with-mutex (mutex)
(loop
@@ -1125,14 +1110,41 @@
(t (sb-thread:condition-wait (mailbox.waitqueue mbox)
mutex))))))))
+
+;;; Auto-flush streams
+
+ ;; XXX race conditions
+ (defvar *auto-flush-streams* '())
+
+ (defvar *auto-flush-thread* nil)
+
+ (defimplementation make-stream-interactive (stream)
+ (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
+ (unless *auto-flush-thread*
+ (setq *auto-flush-thread*
+ (sb-thread:make-thread #'flush-streams
+ :name "auto-flush-thread"))))
+
+ (defun flush-streams ()
+ (loop
+ (setq *auto-flush-streams*
+ (remove-if (lambda (x)
+ (not (and (open-stream-p x)
+ (output-stream-p x))))
+ *auto-flush-streams*))
+ (mapc #'finish-output *auto-flush-streams*)
+ (sleep 0.15)))
+
)
(defimplementation quit-lisp ()
#+sb-thread
(dolist (thread (remove (current-thread) (all-threads)))
- (ignore-errors (sb-thread:terminate-thread thread)))
+ (ignore-errors (sb-thread:interrupt-thread
+ thread (lambda () (sb-ext:quit :recklessly-p t)))))
(sb-ext:quit))
+
;;Trace implementations
;;In SBCL, we have:
@@ -1161,7 +1173,7 @@
(defimplementation toggle-trace (spec)
(ecase (car spec)
- ((setf)
+ ((setf)
(toggle-trace-aux spec))
((:defmethod)
(toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
@@ -1170,3 +1182,17 @@
((:call)
(destructuring-bind (caller callee) (cdr spec)
(toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
+
+;;; Weak datastructures
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ #+#.(swank-backend::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table :weakness :key args)
+ #-#.(swank-backend::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ #+#.(swank-backend::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table :weakness :value args)
+ #-#.(swank-backend::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table args))
Modified: trunk/thirdparty/emacs/slime/swank-scl.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-scl.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-scl.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -12,27 +12,11 @@
;;; swank-mop
-(import-swank-mop-symbols :clos '(:slot-definition-documentation
- :eql-specializer
- :eql-specializer-object))
+(import-swank-mop-symbols :clos '(:slot-definition-documentation))
(defun swank-mop:slot-definition-documentation (slot)
- (slot-value slot 'documentation))
+ (documentation slot t))
-(defun swank-mop:specializer-direct-methods (obj)
- (declare (ignore obj))
- nil)
-
-(deftype swank-mop:eql-specializer ()
- '(or kernel:member-type kernel:numeric-type))
-
-(defun swank-mop:eql-specializer-object (obj)
- (etypecase obj
- (kernel:numeric-type
- (kernel:type-specifier obj))
- (kernel:member-type
- (first (kernel:member-type-members obj)))))
-
;;;; TCP server
;;;
@@ -52,11 +36,25 @@
(defimplementation close-socket (socket)
(ext:close-socket (socket-fd socket)))
-(defimplementation accept-connection (socket &key external-format)
- (let ((external-format (or external-format :iso-latin-1-unix)))
- (make-socket-io-stream (ext:accept-tcp-connection socket)
- external-format)))
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (let ((external-format (or external-format :default))
+ (buffering (or buffering :full))
+ (fd (socket-fd socket)))
+ (loop
+ (let ((ready (sys:wait-until-fd-usable fd :input timeout)))
+ (unless ready
+ (error "Timeout accepting connection on socket: ~S~%" socket)))
+ (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
+ (when new-fd
+ (return (make-socket-io-stream new-fd external-format buffering)))))))
+(defimplementation set-stream-timeout (stream timeout)
+ (check-type timeout (or null real))
+ (if (fboundp 'ext::stream-timeout)
+ (setf (ext::stream-timeout stream) timeout)
+ (setf (slot-value (slot-value stream 'cl::stream) 'cl::timeout) timeout)))
+
;;;;; Sockets
(defun socket-fd (socket)
@@ -70,17 +68,27 @@
(let ((hostent (ext:lookup-host-entry hostname)))
(car (ext:host-entry-addr-list hostent))))
-(defun find-external-format (coding-system)
- (case coding-system
- (:iso-latin-1-unix :iso-8859-1)
- (:utf-8-unix :utf-8)
- (t coding-system)))
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")
+ (:euc-jp "euc-jp" "euc-jp-unix")))
-(defun make-socket-io-stream (fd external-format)
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defun make-socket-io-stream (fd external-format buffering)
"Create a new input/output fd-stream for 'fd."
- (let ((external-format (find-external-format external-format)))
- (sys:make-fd-stream fd :input t :output t :element-type 'base-char
- :external-format external-format)))
+ (let* ((stream (sys:make-fd-stream fd :input t :output t
+ :element-type 'base-char
+ :buffering buffering
+ :external-format external-format)))
+ ;; Ignore character conversion errors. Without this the communication
+ ;; channel is prone to lockup if a character conversion error occurs.
+ (setf (cl::stream-character-conversion-error-value stream) #\?)
+ stream))
;;;; Stream handling
@@ -188,6 +196,7 @@
(dotimes (i copy)
(declare (type kernel:index i))
(setf (aref buffer (+ start i)) (aref input-buffer (+ index i))))
+ (setf (slot-value stream 'index) (+ index copy))
(incf (slot-value stream 'position) copy)
copy)
(waitp
@@ -202,7 +211,8 @@
(t
(setf (slot-value stream 'buffer) new-input)
(setf (slot-value stream 'index) 0)
- (ext:stream-read-chars stream buffer start requested waitp))))))
+ (ext:stream-read-chars stream buffer
+ start requested waitp))))))
(t
0))))
@@ -297,9 +307,11 @@
;;; usage this reduces consing. As the string grows larger then grow to
;;; reduce the cost of copying strings around.
;;;
-(defmethod ext:stream-write-chars ((stream slime-output-stream) string start end)
+(defmethod ext:stream-write-chars ((stream slime-output-stream)
+ string start end waitp)
(declare (simple-string string)
- (type kernel:index start end))
+ (type kernel:index start end)
+ (ignore waitp))
(declare (optimize (speed 3)))
(unless (ext:stream-open-p stream)
(error 'kernel:simple-stream-error
@@ -326,7 +338,7 @@
(let ((column (slot-value stream 'column)))
(declare (type kernel:index column))
(+ column (- end start))))))))
- string)
+ (- end start))
;;;
@@ -365,21 +377,17 @@
(c::warning #'handle-notification-condition))
(funcall function))))
-(defimplementation swank-compile-file (filename load-p
- &optional external-format)
- (let ((external-format (if external-format
- (find-external-format external-format)
- :default)))
- (with-compilation-hooks ()
- (let ((*buffer-name* nil)
- (ext:*ignore-extra-close-parentheses* nil))
- (multiple-value-bind (output-file warnings-p failure-p)
- (compile-file filename :external-format external-format)
- (unless failure-p
- ;; Cache the latest source file for definition-finding.
- (source-cache-get filename (file-write-date filename))
- (when load-p (load output-file)))
- (values output-file warnings-p failure-p))))))
+(defimplementation swank-compile-file (filename load-p external-format)
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (ext:*ignore-extra-close-parentheses* nil))
+ (multiple-value-bind (output-file warnings-p failure-p)
+ (compile-file filename :external-format external-format)
+ (unless failure-p
+ ;; Cache the latest source file for definition-finding.
+ (source-cache-get filename (file-write-date filename))
+ (when load-p (load output-file)))
+ (values output-file warnings-p failure-p)))))
(defimplementation swank-compile-string (string &key buffer position directory)
(declare (ignore directory))
@@ -1158,21 +1166,17 @@
(list symbol))))
((:defined)
(ext:info :alien-type :definition symbol))
- (:unknown
- (return-from describe-definition
- (format nil "Unknown alien type: ~S" symbol))))))))
+ (:unknown :unknown))))))
;;;;; Argument lists
-(defimplementation arglist ((name symbol))
- (cond ((and (symbolp name) (macro-function name))
- (arglist (macro-function name)))
- ((fboundp name)
- (arglist (fdefinition name)))
- (t
- :not-available)))
+(defimplementation arglist (fun)
+ (etypecase fun
+ (function (function-arglist fun))
+ (symbol (function-arglist (or (macro-function fun)
+ (symbol-function fun))))))
-(defimplementation arglist ((fun function))
+(defun function-arglist (fun)
(flet ((compiled-function-arglist (x)
(let ((args (kernel:%function-arglist x)))
(if args
@@ -1418,7 +1422,7 @@
(mapcar #'car (di:frame-catches (nth-frame index))))
(defimplementation return-from-frame (index form)
- (let ((sym (find-symbol (string 'find-debug-tag-for-frame)
+ (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame)
:debug-internals)))
(if sym
(let* ((frame (nth-frame index))
@@ -1563,7 +1567,8 @@
(list (1st sc)))))))))
(defun mv-function-end-breakpoint-values (sigcontext)
- (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di)))
+ (let ((sym (find-symbol (symbol-name '#:function-end-breakpoint-values/standard)
+ :debug-internals)))
(cond (sym (funcall sym sigcontext))
(t (di::get-function-end-breakpoint-values sigcontext)))))
@@ -1577,6 +1582,7 @@
(values :initarg :values :reader breakpoint.values))
(:report (lambda (c stream) (princ (breakpoint.message c) stream))))
+#+nil
(defimplementation condition-extras ((c breakpoint))
;; simply pop up the source buffer
`((:short-frame-source 0)))
@@ -1733,7 +1739,7 @@
:key #'symbol-value)))
(format t ", type: ~A" type-symbol))))))
-(defimplementation inspect-for-emacs ((o t) (inspector scl-inspector))
+(defmethod inspect-for-emacs ((o t) (inspector scl-inspector))
(cond ((di::indirect-value-cell-p o)
(values (format nil "~A is a value cell." o)
`("Value: " (:value ,(c:value-cell-ref o)))))
@@ -1743,7 +1749,8 @@
(scl-inspect o))))
(defun scl-inspect (o)
- (destructuring-bind (text labeledp . parts) (inspect::describe-parts o)
+ (destructuring-bind (text labeledp . parts)
+ (inspect::describe-parts o)
(values (format nil "~A~%" text)
(if labeledp
(loop for (label . value) in parts
@@ -1751,7 +1758,7 @@
(loop for value in parts for i from 0
append (label-value-line i value))))))
-(defmethod inspect-for-emacs :around ((o function) (inspector scl-inspector))
+(defmethod inspect-for-emacs ((o function) (inspector scl-inspector))
(declare (ignore inspector))
(let ((header (kernel:get-type o)))
(cond ((= header vm:function-header-type)
@@ -1771,7 +1778,8 @@
(append
(label-value-line "Function" (kernel:%closure-function o))
`("Environment:" (:newline))
- (loop for i from 0 below (1- (kernel:get-closure-length o))
+ (loop for i from 0 below (- (kernel:get-closure-length o)
+ (1- vm:closure-info-offset))
append (label-value-line
i (kernel:%closure-index-ref o i))))))
((eval::interpreted-function-p o)
@@ -1820,19 +1828,25 @@
(defmethod inspect-for-emacs ((o array) (inspector scl-inspector))
inspector
- (values (format nil "~A is an array." o)
- (label-value-line*
- (:header (describe-primitive-type o))
- (:rank (array-rank o))
- (:fill-pointer (kernel:%array-fill-pointer o))
- (:fill-pointer-p (kernel:%array-fill-pointer-p o))
- (:elements (kernel:%array-available-elements o))
- (:data (kernel:%array-data-vector o))
- (:displacement (kernel:%array-displacement o))
- (:displaced-p (kernel:%array-displaced-p o))
- (:dimensions (array-dimensions o)))))
+ (cond ((kernel:array-header-p o)
+ (values (format nil "~A is an array." o)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:rank (array-rank o))
+ (:fill-pointer (kernel:%array-fill-pointer o))
+ (:fill-pointer-p (kernel:%array-fill-pointer-p o))
+ (:elements (kernel:%array-available-elements o))
+ (:data (kernel:%array-data-vector o))
+ (:displacement (kernel:%array-displacement o))
+ (:displaced-p (kernel:%array-displaced-p o))
+ (:dimensions (array-dimensions o)))))
+ (t
+ (values (format nil "~A is an simple-array." o)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:length (length o)))))))
-(defmethod inspect-for-emacs ((o vector) (inspector scl-inspector))
+(defmethod inspect-for-emacs ((o simple-vector) (inspector scl-inspector))
inspector
(values (format nil "~A is a vector." o)
(append
@@ -1901,8 +1915,8 @@
;;;; Multiprocessing
-(defimplementation spawn (fn &key (name "Anonymous"))
- (thread:thread-create fn :name name))
+(defimplementation spawn (fn &key name)
+ (thread:thread-create fn :name (or name "Anonymous")))
(defvar *thread-id-counter* 0)
(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter"))
@@ -1914,10 +1928,11 @@
(incf *thread-id-counter*)))))
(defimplementation find-thread (id)
- (thread:map-over-threads
- #'(lambda (thread)
- (when (eql (getf (thread:thread-plist thread) 'id) id)
- (return-from find-thread thread)))))
+ (block find-thread
+ (thread:map-over-threads
+ #'(lambda (thread)
+ (when (eql (getf (thread:thread-plist thread) 'id) id)
+ (return-from find-thread thread))))))
(defimplementation thread-name (thread)
(princ-to-string (thread:thread-name thread)))
@@ -1955,9 +1970,9 @@
(defvar *mailbox-lock* (thread:make-lock "Mailbox lock"))
(defstruct (mailbox)
- (lock (thread:make-lock "Thread mailbox" :type :error-check)
+ (lock (thread:make-lock "Thread mailbox" :type :error-check
+ :interruptible nil)
:type thread:error-check-lock)
- (cond-var (thread:make-cond-var "Thread mailbox") :type thread:cond-var)
(queue '() :type list))
(defun mailbox (thread)
@@ -1968,22 +1983,31 @@
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
- (lock (mailbox-lock mbox))
- (cond-var (mailbox-cond-var mbox)))
- (thread:with-lock-held (lock "Mailbox Send")
- (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) (list message)))
- (thread:cond-var-broadcast cond-var))
+ (lock (mailbox-lock mbox)))
+ (sys:without-interrupts
+ (thread:with-lock-held (lock "Mailbox Send")
+ (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
+ (list message)))))
+ (mp:process-wakeup thread)
message))
(defimplementation receive ()
(let* ((mbox (mailbox thread:*thread*))
- (lock (mailbox-lock mbox))
- (cond-var (mailbox-cond-var mbox)))
- (thread:with-lock-held (lock "Mailbox Receive")
- (loop
- (when (mailbox-queue mbox)
- (return (pop (mailbox-queue mbox))))
- (thread:cond-var-timedwait cond-var lock 10 "Mailbox receive wait")))))
+ (lock (mailbox-lock mbox)))
+ (loop
+ (mp:process-wait-with-timeout "Mailbox read wait" 1
+ #'(lambda () (mailbox-queue mbox)))
+ (multiple-value-bind (message winp)
+ (sys:without-interrupts
+ (mp:with-lock-held (lock "Mailbox read")
+ (let ((queue (mailbox-queue mbox)))
+ (cond (queue
+ (setf (mailbox-queue mbox) (cdr queue))
+ (values (car queue) t))
+ (t
+ (values nil nil))))))
+ (when winp
+ (return message))))))
Modified: trunk/thirdparty/emacs/slime/swank-source-file-cache.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-source-file-cache.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-source-file-cache.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -16,6 +16,9 @@
;;; whole file inside Lisp. That way we will still have the matching
;;; version even if the file is later modified on disk. If the file is
;;; later recompiled and reloaded then we replace our cache entry.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
(in-package :swank-backend)
@@ -38,8 +41,10 @@
(defimplementation buffer-first-change (filename)
"Load a file into the cache when the user modifies its buffer.
This is a win if the user then saves the file and tries to M-. into it."
- (unless (source-cached-p filename)
- (ignore-errors (source-cache-get filename (file-write-date filename)))))
+ (unless (or (source-cached-p filename)
+ (not (ignore-errors (probe-file filename))))
+ (ignore-errors
+ (source-cache-get filename (file-write-date filename)))))
(defun get-source-code (filename code-date)
"Return the source code for FILENAME as written on DATE in a string.
@@ -72,7 +77,10 @@
(defun read-file (filename)
"Return the entire contents of FILENAME as a string."
- (with-open-file (s filename :direction :input)
+ (with-open-file (s filename :direction :input
+ :external-format (or (guess-external-format filename)
+ (find-external-format "latin-1")
+ :default))
(let ((string (make-string (file-length s))))
(read-sequence string s)
string)))
Modified: trunk/thirdparty/emacs/slime/swank-source-path-parser.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank-source-path-parser.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-source-path-parser.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -17,6 +17,9 @@
;;; We use a special readtable to get the positions of the subforms.
;;; The readtable stores the start and end position for each subform in
;;; hashtable for later retrieval.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
;;; Taken from swank-cmucl.lisp, by Helmut Eller
@@ -53,25 +56,33 @@
(when fn
(set-macro-character char (make-source-recorder fn source-map)
term tab)))))
+ (suppress-sharp-dot tab)
tab))
-(defvar *source-map* nil
- "The hashtable table used for source position recording.")
+(defun suppress-sharp-dot (readtable)
+ (when (get-macro-character #\# readtable)
+ (let ((sharp-dot (get-dispatch-macro-character #\# #\. readtable)))
+ (set-dispatch-macro-character #\# #\. (lambda (&rest args)
+ (let ((*read-suppress* t))
+ (apply sharp-dot args))
+ (if *read-suppress*
+ (values)
+ (list (gensym "#."))))
+ readtable))))
(defun read-and-record-source-map (stream)
"Read the next object from STREAM.
Return the object together with a hashtable that maps
subexpressions of the object to stream positions."
- (let* ((*source-map* (make-hash-table :test #'eq))
- (*readtable* (make-source-recording-readtable *readtable*
- *source-map*))
+ (let* ((source-map (make-hash-table :test #'eq))
+ (*readtable* (make-source-recording-readtable *readtable* source-map))
(start (file-position stream))
(form (read stream))
(end (file-position stream)))
;; ensure that at least FORM is in the source-map
- (unless (gethash form *source-map*)
- (push (cons start end) (gethash form *source-map*)))
- (values form *source-map*)))
+ (unless (gethash form source-map)
+ (push (cons start end) (gethash form source-map)))
+ (values form source-map)))
(defun read-source-form (n stream)
"Read the Nth toplevel form number with source location recording.
@@ -79,7 +90,8 @@
(let ((*read-suppress* t))
(dotimes (i n)
(read stream)))
- (let ((*read-suppress* nil))
+ (let ((*read-suppress* nil)
+ (*read-eval* nil))
(read-and-record-source-map stream)))
(defun source-path-stream-position (path stream)
Added: trunk/thirdparty/emacs/slime/swank-version.el
===================================================================
--- trunk/thirdparty/emacs/slime/swank-version.el 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank-version.el 2006-11-30 16:32:54 UTC (rev 2092)
@@ -0,0 +1,6 @@
+;;; This is the value for *swank-wire-protocol-version*. NB: This file
+;;; will be loaded by BOTH emacs and lisp, so the syntax used must
+;;; remain compatable between the two dialects. You can assume that
+;;; cl:*package* will be bound to (find-package :SWANK).
+
+(setf *swank-wire-protocol-version* 1)
Modified: trunk/thirdparty/emacs/slime/swank.asd
===================================================================
--- trunk/thirdparty/emacs/slime/swank.asd 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank.asd 2006-11-30 16:32:54 UTC (rev 2092)
@@ -15,7 +15,14 @@
;; (PORT can be zero to mean "any available port".)
;; Then the Swank server is running on localhost:ACTUAL-PORT. You can
;; use `M-x slime-connect' to connect Emacs to it.
+;;
+;; This code has been placed in the Public Domain. All warranties
+;; are disclaimed.
(asdf:defsystem :swank
:components ((:file "swank-loader")))
+(defpackage :swank-loader)
+(defparameter swank-loader::*source-directory*
+ (asdf:component-pathname (asdf:find-system :swank)))
+
Modified: trunk/thirdparty/emacs/slime/swank.lisp
===================================================================
--- trunk/thirdparty/emacs/slime/swank.lisp 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/swank.lisp 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,4 +1,4 @@
-;;; -*- Mode: lisp; outline-regexp: ";;;;;*"; indent-tabs-mode: nil -*-;;;
+;;; -*- outline-regexp:";;;;;*" indent-tabs-mode:nil coding:latin-1-unix -*-
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
@@ -21,11 +21,14 @@
#:ed-in-emacs
#:print-indentation-lossage
#:swank-debugger-hook
+ #:run-after-init-hook
;; These are user-configurable variables:
#:*communication-style*
+ #:*dont-close*
#:*log-events*
#:*log-output*
#:*use-dedicated-output-stream*
+ #:*dedicated-output-stream-port*
#:*configure-emacs-indentation*
#:*readtable-alist*
#:*globally-redirect-io*
@@ -53,6 +56,7 @@
(in-package :swank)
+
;;;; Top-level variables, constants, macros
(defconstant cl-package (find-package :cl)
@@ -62,11 +66,11 @@
"The KEYWORD package.")
(defvar *canonical-package-nicknames*
- '(("COMMON-LISP-USER" . "CL-USER"))
+ `((:common-lisp-user . :cl-user))
"Canonical package names to use instead of shortest name/nickname.")
(defvar *auto-abbreviate-dotted-packages* t
- "Automatically abbreviate dotted package names to their last component when T.")
+ "Abbreviate dotted package names to their last component if T.")
(defvar *swank-io-package*
(let ((package (make-package :swank-io-package :use '())))
@@ -127,7 +131,6 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export ',name :swank))))
-(declaim (ftype (function () nil) missing-arg))
(defun missing-arg ()
"A function that the compiler knows will never to return a value.
You can use (MISSING-ARG) as the initform for defstruct slots that
@@ -135,6 +138,7 @@
include some arbitrary initial value like NIL."
(error "A required &KEY or &OPTIONAL argument was not supplied."))
+
;;;; Hooks
;;;
;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
@@ -163,6 +167,13 @@
(defvar *pre-reply-hook* '()
"Hook run (without arguments) immediately before replying to an RPC.")
+(defvar *after-init-hook* '()
+ "Hook run after user init files are loaded.")
+
+(defun run-after-init-hook ()
+ (run-hook *after-init-hook*))
+
+
;;;; Connections
;;;
;;; Connection structures represent the network connections between
@@ -171,8 +182,6 @@
;;; used solely to pipe user-output to Emacs (an optimization).
;;;
-(defvar *coding-system* ':iso-latin-1-unix)
-
(defstruct (connection
(:conc-name connection.)
(:print-function print-connection))
@@ -217,9 +226,7 @@
;; The communication style used.
(communication-style nil :type (member nil :spawn :sigio :fd-handler))
;; The coding system for network streams.
- (external-format *coding-system* :type (member :iso-latin-1-unix
- :emacs-mule-unix
- :utf-8-unix)))
+ (coding-system ))
(defun print-connection (conn stream depth)
(declare (ignore depth))
@@ -248,16 +255,25 @@
"Return the value of *SWANK-STATE-STACK*."
*swank-state-stack*)
-(define-condition slime-protocol-error (error)
- ((condition :initarg :condition :reader slime-protocol-error.condition))
+;; A conditions to include backtrace information
+(define-condition swank-error (error)
+ ((condition :initarg :condition :reader swank-error.condition)
+ (backtrace :initarg :backtrace :reader swank-error.backtrace))
(:report (lambda (condition stream)
- (format stream "~A" (slime-protocol-error.condition condition)))))
+ (princ (swank-error.condition condition) stream))))
+(defun make-swank-error (condition)
+ (let ((bt (ignore-errors
+ (call-with-debugging-environment
+ (lambda ()(backtrace 0 nil))))))
+ (make-condition 'swank-error :condition condition :backtrace bt)))
+
(add-hook *new-connection-hook* 'notify-backend-of-connection)
(defun notify-backend-of-connection (connection)
(declare (ignore connection))
(emacs-connected))
+
;;;; Helper macros
(defmacro with-io-redirection ((connection) &body body)
@@ -276,10 +292,8 @@
(defun call-with-connection (connection fun)
(let ((*emacs-connection* connection))
- (catch 'slime-toplevel
- (with-io-redirection (*emacs-connection*)
- (let ((*debugger-hook* #'swank-debugger-hook))
- (funcall fun))))))
+ (with-io-redirection (*emacs-connection*)
+ (call-with-debugger-hook #'swank-debugger-hook fun))))
(defmacro without-interrupts (&body body)
`(call-without-interrupts (lambda () ,@body)))
@@ -318,35 +332,114 @@
(defvar *log-events* nil)
(defvar *log-output* *error-output*)
+(defvar *event-history* (make-array 40 :initial-element nil)
+ "A ring buffer to record events for better error messages.")
+(defvar *event-history-index* 0)
+(defvar *enable-event-history* t)
(defun log-event (format-string &rest args)
"Write a message to *terminal-io* when *log-events* is non-nil.
Useful for low level debugging."
+ (when *enable-event-history*
+ (setf (aref *event-history* *event-history-index*)
+ (format nil "~?" format-string args))
+ (setf *event-history-index*
+ (mod (1+ *event-history-index*) (length *event-history*))))
(when *log-events*
(apply #'format *log-output* format-string args)
(force-output *log-output*)))
+(defun event-history-to-list ()
+ "Return the list of events (older events first)."
+ (let ((arr *event-history*)
+ (idx *event-history-index*))
+ (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
+
+(defun dump-event-history (stream)
+ (dolist (e (event-history-to-list))
+ (dump-event e stream)))
+
+(defun dump-event (event stream)
+ (cond ((stringp event)
+ (write-string (escape-non-ascii event) stream))
+ ((null event))
+ (t (format stream "Unexpected event: ~A~%" event))))
+
+(defun escape-non-ascii (string)
+ "Return a string like STRING but with non-ascii chars escaped."
+ (cond ((ascii-string-p string) string)
+ (t (with-output-to-string (out)
+ (loop for c across string do
+ (cond ((ascii-char-p c) (write-char c out))
+ (t (format out "\\x~4,'0X" (char-code c)))))))))
+
+(defun ascii-string-p (o)
+ (and (stringp o)
+ (every #'ascii-char-p o)))
+
+(defun ascii-char-p (c)
+ (<= (char-code c) 127))
+
+(defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
+ "Just like do-symbols, but makes sure a symbol is visited only once."
+ (let ((seen-ht (gensym "SEEN-HT")))
+ `(let ((,seen-ht (make-hash-table :test #'eq)))
+ (do-symbols (,var ,package ,result-form)
+ (unless (gethash ,var ,seen-ht)
+ (setf (gethash ,var ,seen-ht) t)
+ ,@body)))))
+
+
;;;; TCP Server
-(defvar *use-dedicated-output-stream* t)
+(defvar *use-dedicated-output-stream* nil
+ "When T swank will attempt to create a second connection to
+ Emacs which is used just to send output.")
+
+(defvar *dedicated-output-stream-port* 0
+ "Which port we should use for the dedicated output stream.")
+
(defvar *communication-style* (preferred-communication-style))
+(defvar *dont-close* nil
+ "Default value of :dont-close argument to start-server and
+ create-server.")
+
+(defvar *dedicated-output-stream-buffering*
+ (if (eq *communication-style* :spawn) :full :none)
+ "The buffering scheme that should be used for the output stream.
+Valid values are :none, :line, and :full.")
+
+(defvar *coding-system* "iso-latin-1-unix")
+
(defun start-server (port-file &key (style *communication-style*)
- dont-close (external-format *coding-system*))
+ (dont-close *dont-close*)
+ (coding-system *coding-system*))
"Start the server and write the listen port number to PORT-FILE.
This is the entry point for Emacs."
- (setup-server 0 (lambda (port) (announce-server-port port-file port))
- style dont-close external-format))
+ (flet ((start-server-aux ()
+ (setup-server 0 (lambda (port)
+ (announce-server-port port-file port))
+ style dont-close
+ (find-external-format-or-lose coding-system))))
+ (if (eq style :spawn)
+ (initialize-multiprocessing #'start-server-aux)
+ (start-server-aux))))
(defun create-server (&key (port default-server-port)
(style *communication-style*)
- dont-close (external-format *coding-system*))
+ (dont-close *dont-close*)
+ (coding-system *coding-system*))
"Start a SWANK server on PORT running in STYLE.
If DONT-CLOSE is true then the listen socket will accept multiple
connections, otherwise it will be closed after the first."
(setup-server port #'simple-announce-function style dont-close
- external-format))
+ (find-external-format-or-lose coding-system)))
+(defun find-external-format-or-lose (coding-system)
+ (or (find-external-format coding-system)
+ (error "Unsupported coding system: ~s" coding-system)))
+
(defun create-swank-server (&optional (port default-server-port)
(style *communication-style*)
(announce-fn #'simple-announce-function)
@@ -364,32 +457,42 @@
(serve-connection socket style dont-close external-format)))
(ecase style
(:spawn
- (spawn (lambda () (loop do (serve) while dont-close))
+ (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close))
:name "Swank"))
((:fd-handler :sigio)
(add-fd-handler socket (lambda () (serve))))
- ((nil)
- (unwind-protect (loop do (serve) while dont-close)
- (close-socket socket))))
+ ((nil) (loop do (serve) while dont-close)))
port)))
(defun serve-connection (socket style dont-close external-format)
- (let ((client (accept-authenticated-connection
- socket :external-format external-format)))
- (unless dont-close
- (close-socket socket))
- (let ((connection (create-connection client style external-format)))
- (run-hook *new-connection-hook* connection)
- (push connection *connections*)
- (serve-requests connection))))
+ (let ((closed-socket-p nil))
+ (unwind-protect
+ (let ((client (accept-authenticated-connection
+ socket :external-format external-format)))
+ (unless dont-close
+ (close-socket socket)
+ (setf closed-socket-p t))
+ (let ((connection (create-connection client style)))
+ (run-hook *new-connection-hook* connection)
+ (push connection *connections*)
+ (serve-requests connection)))
+ (unless (or dont-close closed-socket-p)
+ (close-socket socket)))))
(defun accept-authenticated-connection (&rest args)
(let ((new (apply #'accept-connection args))
- (secret (slime-secret)))
- (when secret
- (unless (string= (decode-message new) secret)
- (close new)
- (error "Incoming connection doesn't know the password.")))
+ (success nil))
+ (unwind-protect
+ (let ((secret (slime-secret)))
+ (when secret
+ (set-stream-timeout new 20)
+ (let ((first-val (decode-message new)))
+ (unless (and (stringp first-val) (string= first-val secret))
+ (error "Incoming connection doesn't know the password."))))
+ (set-stream-timeout new nil)
+ (setf success t))
+ (unless success
+ (close new :abort t)))
new))
(defun slime-secret ()
@@ -414,7 +517,8 @@
(defun simple-announce-function (port)
(when *swank-debug-p*
- (format *debug-io* "~&;; Swank started at port: ~D.~%" port)))
+ (format *debug-io* "~&;; Swank started at port: ~D.~%" port)
+ (force-output *debug-io*)))
(defun open-streams (connection)
"Return the 4 streams for IO redirection:
@@ -440,8 +544,7 @@
stream (or NIL if none was created)."
(if *use-dedicated-output-stream*
(let ((stream (open-dedicated-output-stream
- (connection.socket-io connection)
- (connection.external-format connection))))
+ (connection.socket-io connection))))
(values (lambda (string)
(write-string string stream)
(force-output stream))
@@ -450,34 +553,47 @@
(with-connection (connection)
(with-simple-restart
(abort "Abort sending output to Emacs.")
- (send-to-emacs `(:read-output ,string)))))
+ (send-to-emacs `(:write-string ,string)))))
nil)))
-(defun open-dedicated-output-stream (socket-io external-format)
+(defun open-dedicated-output-stream (socket-io)
"Open a dedicated output connection to the Emacs on SOCKET-IO.
Return an output stream suitable for writing program output.
This is an optimized way for Lisp to deliver output to Emacs."
- (let* ((socket (create-socket *loopback-interface* 0))
- (port (local-port socket)))
- (encode-message `(:open-dedicated-output-stream ,port) socket-io)
- (accept-authenticated-connection
- socket :external-format external-format)))
+ (let ((socket (create-socket *loopback-interface*
+ *dedicated-output-stream-port*)))
+ (unwind-protect
+ (let ((port (local-port socket)))
+ (encode-message `(:open-dedicated-output-stream ,port) socket-io)
+ (let ((dedicated (accept-authenticated-connection
+ socket
+ :external-format
+ (or (ignore-errors
+ (stream-external-format socket-io))
+ :default)
+ :buffering *dedicated-output-stream-buffering*
+ :timeout 30)))
+ (close-socket socket)
+ (setf socket nil)
+ dedicated))
+ (when socket
+ (close-socket socket)))))
(defun handle-request (connection)
- "Read and process one request. The processing is done in the extend
+ "Read and process one request. The processing is done in the extent
of the toplevel restart."
(assert (null *swank-state-stack*))
- (let ((*swank-state-stack* '(:handle-request))
- (*debugger-hook* nil))
+ (let ((*swank-state-stack* '(:handle-request)))
(with-connection (connection)
- (with-simple-restart (abort "Abort handling SLIME request.")
+ (with-simple-restart (abort-request "Abort handling SLIME request.")
(read-from-emacs)))))
(defun current-socket-io ()
(connection.socket-io *emacs-connection*))
-(defun close-connection (c &optional condition)
+(defun close-connection (c &optional condition backtrace)
+ (format *debug-io* "~&;; swank:close-connection: ~A~%" condition)
(let ((cleanup (connection.cleanup c)))
(when cleanup
(funcall cleanup c)))
@@ -486,21 +602,43 @@
(close (connection.dedicated-output c)))
(setf *connections* (remove c *connections*))
(run-hook *connection-closed-hook* c)
- (when condition
- (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" condition)
+ (when (and condition (not (typep condition 'end-of-file)))
+ (finish-output *debug-io*)
+ (format *debug-io* "~&;; Event history start:~%")
+ (dump-event-history *debug-io*)
+ (format *debug-io* ";; Event history end.~%~
+ ;; Backtrace:~%~{~A~%~}~
+ ;; Connection to Emacs lost. [~%~
+ ;; condition: ~A~%~
+ ;; type: ~S~%~
+ ;; encoding: ~A style: ~S dedicated: ~S]~%"
+ backtrace
+ (escape-non-ascii (safe-condition-message condition) )
+ (type-of condition)
+ (ignore-errors (stream-external-format (connection.socket-io c)))
+ (connection.communication-style c)
+ *use-dedicated-output-stream*)
(finish-output *debug-io*)))
(defmacro with-reader-error-handler ((connection) &body body)
- `(handler-case (progn ,@body)
- (slime-protocol-error (e)
- (close-connection ,connection e))))
+ (let ((con (gensym)))
+ `(let ((,con ,connection))
+ (handler-case
+ (progn ,@body)
+ (swank-error (e)
+ (close-connection ,con
+ (swank-error.condition e)
+ (swank-error.backtrace e)))))))
-(defun simple-break ()
+(defslimefun simple-break ()
(with-simple-restart (continue "Continue from interrupt.")
- (let ((*debugger-hook* #'swank-debugger-hook))
- (invoke-debugger
- (make-condition 'simple-error
- :format-control "Interrupt from Emacs")))))
+ (call-with-debugger-hook
+ #'swank-debugger-hook
+ (lambda ()
+ (invoke-debugger
+ (make-condition 'simple-error
+ :format-control "Interrupt from Emacs")))))
+ nil)
;;;;;; Thread based communication
@@ -519,12 +657,15 @@
(defun repl-thread (connection)
(let ((thread (connection.repl-thread connection)))
- (if (thread-alive-p thread)
- thread
- (setf (connection.repl-thread connection)
- (spawn-repl-thread connection "new-repl-thread")))))
+ (when (not thread)
+ (log-event "ERROR: repl-thread is nil"))
+ (assert thread)
+ (cond ((thread-alive-p thread)
+ thread)
+ (t
+ (setf (connection.repl-thread connection)
+ (spawn-repl-thread connection "new-repl-thread"))))))
-
(defun find-worker-thread (id)
(etypecase id
((member t)
@@ -582,9 +723,8 @@
(encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io))
((:read-string thread &rest args)
(encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
- ((:evaluate-in-emacs string thread &rest args)
- (encode-message `(:evaluate-in-emacs ,string ,(thread-id thread) ,@args)
- socket-io))
+ ((:y-or-n-p thread &rest args)
+ (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io))
((:read-aborted thread &rest args)
(encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
((:emacs-return-string thread-id tag string)
@@ -593,46 +733,62 @@
(encode-message `(:eval ,(thread-id thread) ,@args) socket-io))
((:emacs-return thread-id tag value)
(send (find-thread thread-id) `(take-input ,tag ,value)))
- (((:read-output :new-package :new-features :ed :%apply :indentation-update
- :eval-no-wait)
+ (((:write-string :presentation-start :presentation-end
+ :new-package :new-features :ed :%apply :indentation-update
+ :eval-no-wait :background-message)
&rest _)
(declare (ignore _))
(encode-message event socket-io))))
(defun spawn-threads-for-connection (connection)
- (let* ((socket-io (connection.socket-io connection))
- (control-thread (spawn (lambda ()
- (let ((*debugger-hook* nil))
- (dispatch-loop socket-io connection)))
- :name "control-thread")))
- (setf (connection.control-thread connection) control-thread)
- (let ((reader-thread (spawn (lambda ()
- (let ((*debugger-hook* nil))
- (read-loop control-thread socket-io
- connection)))
- :name "reader-thread"))
- (repl-thread (spawn-repl-thread connection "repl-thread")))
- (setf (connection.reader-thread connection) reader-thread)
- (setf (connection.repl-thread connection) repl-thread)
- connection)))
+ (macrolet ((without-debugger-hook (&body body)
+ `(call-with-debugger-hook nil (lambda () ,@body))))
+ (let* ((socket-io (connection.socket-io connection))
+ (control-thread (spawn (lambda ()
+ (without-debugger-hook
+ (dispatch-loop socket-io connection)))
+ :name "control-thread")))
+ (setf (connection.control-thread connection) control-thread)
+ (let ((reader-thread (spawn (lambda ()
+ (let ((go (receive)))
+ (assert (eq go 'accept-input)))
+ (without-debugger-hook
+ (read-loop control-thread socket-io
+ connection)))
+ :name "reader-thread"))
+ (repl-thread (spawn-repl-thread connection "repl-thread")))
+ (setf (connection.repl-thread connection) repl-thread)
+ (setf (connection.reader-thread connection) reader-thread)
+ (send reader-thread 'accept-input)
+ connection))))
(defun cleanup-connection-threads (connection)
(let ((threads (list (connection.repl-thread connection)
(connection.reader-thread connection)
(connection.control-thread connection))))
(dolist (thread threads)
- (unless (equal (current-thread) thread)
+ (when (and thread
+ (thread-alive-p thread)
+ (not (equal (current-thread) thread)))
(kill-thread thread)))))
(defun repl-loop (connection)
- (with-connection (connection)
- (loop (handle-request connection))))
+ (loop (handle-request connection)))
(defun process-available-input (stream fn)
- (loop while (and (open-stream-p stream)
- (listen stream))
+ (loop while (input-available-p stream)
do (funcall fn)))
+(defun input-available-p (stream)
+ ;; return true iff we can read from STREAM without waiting or if we
+ ;; hit EOF
+ (let ((c (read-char-no-hang stream nil :eof)))
+ (cond ((not c) nil)
+ ((eq c :eof) t)
+ (t
+ (unread-char c stream)
+ t))))
+
;;;;;; Signal driven IO
(defun install-sigio-handler (connection)
@@ -660,15 +816,17 @@
(process-available-input
client (lambda () (handle-request connection)))))
((eq (car *swank-state-stack*) :read-next-form))
- (t (process-available-input client #'read-from-emacs)))))
- (setq *debugger-hook*
- (lambda (c h)
- (with-reader-error-handler (connection)
- (block debugger
- (with-connection (connection)
- (swank-debugger-hook c h)
- (return-from debugger))
- (abort)))))
+ (t
+ (process-available-input client #'read-from-emacs)))))
+ ;;;; handle sigint
+ ;;(install-debugger-globally
+ ;; (lambda (c h)
+ ;; (with-reader-error-handler (connection)
+ ;; (block debugger
+ ;; (with-connection (connection)
+ ;; (swank-debugger-hook c h)
+ ;; (return-from debugger))
+ ;; (abort)))))
(add-fd-handler client #'handler)
(handler))))
@@ -678,8 +836,12 @@
;;;;;; Simple sequential IO
(defun simple-serve-requests (connection)
- (with-reader-error-handler (connection)
- (loop (handle-request connection))))
+ (unwind-protect
+ (with-simple-restart (close-connection "Close SLIME connection")
+ (with-reader-error-handler (connection)
+ (loop
+ (handle-request connection))))
+ (close-connection connection)))
(defun read-from-socket-io ()
(let ((event (decode-message (current-socket-io))))
@@ -705,15 +867,17 @@
(encode-message o (current-socket-io)))))
(destructure-case event
(((:debug-activate :debug :debug-return :read-string :read-aborted
- :eval)
+ :y-or-n-p :eval)
thread &rest args)
(declare (ignore thread))
(send `(,(car event) 0 ,@args)))
((:return thread &rest args)
(declare (ignore thread))
(send `(:return ,@args)))
- (((:read-output :new-package :new-features :debug-condition
- :indentation-update :ed :%apply :eval-no-wait)
+ (((:write-string :new-package :new-features :debug-condition
+ :presentation-start :presentation-end
+ :indentation-update :ed :%apply :eval-no-wait
+ :background-message)
&rest _)
(declare (ignore _))
(send event)))))
@@ -726,35 +890,39 @@
(connection.user-input connection) in)
connection))
-(defun create-connection (socket-io style external-format)
- (let ((c (ecase style
- (:spawn
- (make-connection :socket-io socket-io
- :read #'read-from-control-thread
- :send #'send-to-control-thread
- :serve-requests #'spawn-threads-for-connection
- :cleanup #'cleanup-connection-threads))
- (:sigio
- (make-connection :socket-io socket-io
- :read #'read-from-socket-io
- :send #'send-to-socket-io
- :serve-requests #'install-sigio-handler
- :cleanup #'deinstall-sigio-handler))
- (:fd-handler
- (make-connection :socket-io socket-io
- :read #'read-from-socket-io
- :send #'send-to-socket-io
- :serve-requests #'install-fd-handler
- :cleanup #'deinstall-fd-handler))
- ((nil)
- (make-connection :socket-io socket-io
- :read #'read-from-socket-io
- :send #'send-to-socket-io
- :serve-requests #'simple-serve-requests)))))
- (setf (connection.communication-style c) style)
- (setf (connection.external-format c) external-format)
- (initialize-streams-for-connection c)
- c))
+(defun create-connection (socket-io style)
+ (let ((success nil))
+ (unwind-protect
+ (let ((c (ecase style
+ (:spawn
+ (make-connection :socket-io socket-io
+ :read #'read-from-control-thread
+ :send #'send-to-control-thread
+ :serve-requests #'spawn-threads-for-connection
+ :cleanup #'cleanup-connection-threads))
+ (:sigio
+ (make-connection :socket-io socket-io
+ :read #'read-from-socket-io
+ :send #'send-to-socket-io
+ :serve-requests #'install-sigio-handler
+ :cleanup #'deinstall-sigio-handler))
+ (:fd-handler
+ (make-connection :socket-io socket-io
+ :read #'read-from-socket-io
+ :send #'send-to-socket-io
+ :serve-requests #'install-fd-handler
+ :cleanup #'deinstall-fd-handler))
+ ((nil)
+ (make-connection :socket-io socket-io
+ :read #'read-from-socket-io
+ :send #'send-to-socket-io
+ :serve-requests #'simple-serve-requests)))))
+ (setf (connection.communication-style c) style)
+ (initialize-streams-for-connection c)
+ (setf success t)
+ c)
+ (unless success
+ (close socket-io :abort t)))))
;;;; IO to Emacs
@@ -784,12 +952,18 @@
(defvar *globally-redirect-io* nil
"When non-nil globally redirect all standard streams to Emacs.")
-(defmacro setup-stream-indirection (stream-var)
+;;;;; Global redirection setup
+
+(defvar *saved-global-streams* '()
+ "A plist to save and restore redirected stream objects.
+E.g. the value for '*standard-output* holds the stream object
+for *standard-output* before we install our redirection.")
+
+(defun setup-stream-indirection (stream-var &optional stream)
"Setup redirection scaffolding for a global stream variable.
Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
-1. Saves the value of *STANDARD-INPUT* in a variable called
-*REAL-STANDARD-INPUT*.
+1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
*STANDARD-INPUT*.
@@ -801,50 +975,48 @@
effective global value for *STANDARD-INPUT*. This way we can assign
the effective global value even when *STANDARD-INPUT* is shadowed by a
dynamic binding."
- (let ((real-stream-var (prefixed-var "REAL" stream-var))
- (current-stream-var (prefixed-var "CURRENT" stream-var)))
- `(progn
- ;; Save the real stream value for the future.
- (defvar ,real-stream-var ,stream-var)
- ;; Define a new variable for the effective stream.
- ;; This can be reassigned.
- (defvar ,current-stream-var ,stream-var)
- ;; Assign the real binding as a synonym for the current one.
- (setq ,stream-var (make-synonym-stream ',current-stream-var)))))
+ (let ((current-stream-var (prefixed-var '#:current stream-var))
+ (stream (or stream (symbol-value stream-var))))
+ ;; Save the real stream value for the future.
+ (setf (getf *saved-global-streams* stream-var) stream)
+ ;; Define a new variable for the effective stream.
+ ;; This can be reassigned.
+ (proclaim `(special ,current-stream-var))
+ (set current-stream-var stream)
+ ;; Assign the real binding as a synonym for the current one.
+ (set stream-var (make-synonym-stream current-stream-var))))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun prefixed-var (prefix variable-symbol)
- "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
- (let ((basename (subseq (symbol-name variable-symbol) 1)))
- (intern (format nil "*~A-~A" prefix basename) :swank))))
+(defun prefixed-var (prefix variable-symbol)
+ "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
+ (let ((basename (subseq (symbol-name variable-symbol) 1)))
+ (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
-;;;;; Global redirection setup
-
-(setup-stream-indirection *standard-output*)
-(setup-stream-indirection *error-output*)
-(setup-stream-indirection *trace-output*)
-(setup-stream-indirection *standard-input*)
-(setup-stream-indirection *debug-io*)
-(setup-stream-indirection *query-io*)
-(setup-stream-indirection *terminal-io*)
-
-(defparameter *standard-output-streams*
+(defvar *standard-output-streams*
'(*standard-output* *error-output* *trace-output*)
"The symbols naming standard output streams.")
-(defparameter *standard-input-streams*
+(defvar *standard-input-streams*
'(*standard-input*)
"The symbols naming standard input streams.")
-(defparameter *standard-io-streams*
+(defvar *standard-io-streams*
'(*debug-io* *query-io* *terminal-io*)
"The symbols naming standard io streams.")
+(defun init-global-stream-redirection ()
+ (when *globally-redirect-io*
+ (mapc #'setup-stream-indirection
+ (append *standard-output-streams*
+ *standard-input-streams*
+ *standard-io-streams*))))
+
+(add-hook *after-init-hook* 'init-global-stream-redirection)
+
(defun globally-redirect-io-to-connection (connection)
"Set the standard I/O streams to redirect to CONNECTION.
Assigns *CURRENT-<STREAM>* for all standard streams."
(dolist (o *standard-output-streams*)
- (set (prefixed-var "CURRENT" o)
+ (set (prefixed-var '#:current o)
(connection.user-output connection)))
;; FIXME: If we redirect standard input to Emacs then we get the
;; regular Lisp top-level trying to read from our REPL.
@@ -857,10 +1029,10 @@
;; Meanwhile we just leave *standard-input* alone.
#+NIL
(dolist (i *standard-input-streams*)
- (set (prefixed-var "CURRENT" i)
+ (set (prefixed-var '#:current i)
(connection.user-input connection)))
(dolist (io *standard-io-streams*)
- (set (prefixed-var "CURRENT" io)
+ (set (prefixed-var '#:current io)
(connection.user-io connection))))
(defun revert-global-io-redirection ()
@@ -868,8 +1040,8 @@
(dolist (stream-var (append *standard-output-streams*
*standard-input-streams*
*standard-io-streams*))
- (set (prefixed-var "CURRENT" stream-var)
- (symbol-value (prefixed-var "REAL" stream-var)))))
+ (set (prefixed-var '#:current stream-var)
+ (getf *saved-global-streams* stream-var))))
;;;;; Global redirection hooks
@@ -924,20 +1096,16 @@
(receive))
(defun decode-message (stream)
- "Read an S-expression from STREAM using the SLIME protocol.
-If a protocol error occurs then a SLIME-PROTOCOL-ERROR is signalled."
+ "Read an S-expression from STREAM using the SLIME protocol."
(let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
- (handler-case
- (let* ((length (decode-message-length stream))
- (string (make-string length))
- (pos (read-sequence string stream)))
- (assert (= pos length) ()
- "Short read: length=~D pos=~D" length pos)
- (let ((form (read-form string)))
- (log-event "READ: ~A~%" string)
- form))
- (serious-condition (c)
- (error (make-condition 'slime-protocol-error :condition c))))))
+ (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
+ (let* ((length (decode-message-length stream))
+ (string (make-string length))
+ (pos (read-sequence string stream)))
+ (assert (= pos length) ()
+ "Short read: length=~D pos=~D" length pos)
+ (log-event "READ: ~S~%" string)
+ (read-form string)))))
(defun decode-message-length (stream)
(let ((buffer (make-string 6)))
@@ -965,12 +1133,13 @@
(defun encode-message (message stream)
(let* ((string (prin1-to-string-for-emacs message))
- (length (1+ (length string))))
+ (length (length string)))
(log-event "WRITE: ~A~%" string)
- (format stream "~6,'0x" length)
+ (let ((*print-pretty* nil))
+ (format stream "~6,'0x" length))
(write-string string stream)
- (terpri stream)
- (force-output stream)))
+ ;;(terpri stream)
+ (finish-output stream)))
(defun prin1-to-string-for-emacs (object)
(with-standard-io-syntax
@@ -982,7 +1151,7 @@
(defun force-user-output ()
(force-output (connection.user-io *emacs-connection*))
- (force-output (connection.user-output *emacs-connection*)))
+ (finish-output (connection.user-output *emacs-connection*)))
(defun clear-user-input ()
(clear-input (connection.user-input *emacs-connection*)))
@@ -1005,54 +1174,94 @@
(unless ok
(send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))
+(defun y-or-n-p-in-emacs (format-string &rest arguments)
+ "Like y-or-n-p, but ask in the Emacs minibuffer."
+ (let ((tag (incf *read-input-catch-tag*))
+ (question (apply #'format nil format-string arguments)))
+ (force-output)
+ (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question))
+ (catch (intern-catch-tag tag)
+ (loop (read-from-emacs)))))
+
(defslimefun take-input (tag input)
"Return the string INPUT to the continuation TAG."
(throw (intern-catch-tag tag) input))
-(defun evaluate-in-emacs (string)
- (let ((tag (incf *read-input-catch-tag*)))
- (force-output)
- (send-to-emacs `(:evaluate-in-emacs ,string ,(current-thread) ,tag))
- (let ((ok nil))
- (unwind-protect
- (prog1 (catch (intern-catch-tag tag)
- (loop (read-from-emacs)))
- (setq ok t))
- (unless ok
- (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))
+(defun process-form-for-emacs (form)
+ "Returns a string which emacs will read as equivalent to
+FORM. FORM can contain lists, strings, characters, symbols and
+numbers.
+Characters are converted emacs' ?<char> notaion, strings are left
+as they are (except for espacing any nested \" chars, numbers are
+printed in base 10 and symbols are printed as their symbol-nome
+converted to lower case."
+ (etypecase form
+ (string (format nil "~S" form))
+ (cons (format nil "(~A . ~A)"
+ (process-form-for-emacs (car form))
+ (process-form-for-emacs (cdr form))))
+ (character (format nil "?~C" form))
+ (symbol (string-downcase (symbol-name form)))
+ (number (let ((*print-base* 10))
+ (princ-to-string form)))))
+
(defun eval-in-emacs (form &optional nowait)
"Eval FORM in Emacs."
- (destructuring-bind (fun &rest args) form
- (let ((fun (string-downcase (string fun))))
- (cond (nowait
- (send-to-emacs `(:eval-no-wait ,fun ,args)))
- (t
- (force-output)
- (let* ((tag (incf *read-input-catch-tag*)))
- (send-to-emacs `(:eval ,(current-thread) ,tag ,fun ,args))
- (receive-eval-result tag)))))))
+ (cond (nowait
+ (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
+ (t
+ (force-output)
+ (let* ((tag (incf *read-input-catch-tag*))
+ (value (catch (intern-catch-tag tag)
+ (send-to-emacs
+ `(:eval ,(current-thread) ,tag
+ ,(process-form-for-emacs form)))
+ (loop (read-from-emacs)))))
+ (destructure-case value
+ ((:ok value) value)
+ ((:abort) (abort)))))))
-(defun receive-eval-result (tag)
- (let ((value (catch (intern-catch-tag tag)
- (loop (read-from-emacs)))))
- (destructure-case value
- ((:ok value) value)
- ((:abort) (abort)))))
-
+(defvar *swank-wire-protocol-version* nil
+ "The version of the swank/slime communication protocol.")
+
(defslimefun connection-info ()
- "Return a list of the form:
-\(PID IMPLEMENTATION-TYPE IMPLEMENTATION-NAME FEATURES
- COMMUNICATION-STYLE IMPLEMENTATION-VERSION MACHINE-INSTANCE)."
+ "Return a key-value list of the form:
+\(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
+PID: is the process-id of Lisp process (or nil, depending on the STYLE)
+STYLE: the communication style
+LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
+FEATURES: a list of keywords
+PACKAGE: a list (&key NAME PROMPT)
+VERSION: the protocol version"
(setq *slime-features* *features*)
- (list (getpid)
- (lisp-implementation-type)
- (lisp-implementation-type-name)
- (features-for-emacs)
- (connection.communication-style *emacs-connection*)
- (lisp-implementation-version)
- (machine-instance)))
+ `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
+ :lisp-implementation (:type ,(lisp-implementation-type)
+ :name ,(lisp-implementation-type-name)
+ :version ,(lisp-implementation-version))
+ :machine (:instance ,(machine-instance)
+ :type ,(machine-type)
+ :version ,(machine-version))
+ :features ,(features-for-emacs)
+ :package (:name ,(package-name *package*)
+ :prompt ,(package-string-for-prompt *package*))
+ :version ,*swank-wire-protocol-version*))
+(defslimefun io-speed-test (&optional (n 5000) (m 1))
+ (let* ((s *standard-output*)
+ (*trace-output* (make-broadcast-stream s *log-output*)))
+ (time (progn
+ (dotimes (i n)
+ (format s "~D abcdefghijklm~%" i)
+ (when (zerop (mod n m))
+ (force-output s)))
+ (finish-output s)
+ (when *emacs-connection*
+ (eval-in-emacs '(message "done.")))))
+ (terpri *trace-output*)
+ (finish-output *trace-output*)
+ nil))
+
;;;; Reading and printing
@@ -1089,6 +1298,19 @@
(let ((*readtable* *buffer-readtable*))
(call-with-syntax-hooks fun)))))
+(defun to-string (object)
+ "Write OBJECT in the *BUFFER-PACKAGE*.
+The result may not be readable. Handles problems with PRINT-OBJECT methods
+gracefully."
+ (with-buffer-syntax ()
+ (let ((*print-readably* nil))
+ (handler-case
+ (prin1-to-string object)
+ (error ()
+ (with-output-to-string (s)
+ (print-unreadable-object (object s :type t :identity t)
+ (princ "<<error printing object>>" s))))))))
+
(defun from-string (string)
"Read string in the *BUFFER-PACKAGE*"
(with-buffer-syntax ()
@@ -1104,28 +1326,55 @@
(internp (search "::" string)))
(values symbol package internp)))
-;; FIXME: Escape chars are ignored
-(defun casify (string)
- "Convert string accoring to readtable-case."
+(defun tokenize-symbol-thoroughly (string)
+ "This version of tokenize-symbol handles escape characters."
+ (let ((package nil)
+ (token (make-array (length string) :element-type 'character
+ :fill-pointer 0))
+ (backslash nil)
+ (vertical nil)
+ (internp nil))
+ (loop for char across string
+ do (cond
+ (backslash
+ (vector-push-extend char token)
+ (setq backslash nil))
+ ((char= char #\\) ; Quotes next character, even within |...|
+ (setq backslash t))
+ ((char= char #\|)
+ (setq vertical t))
+ (vertical
+ (vector-push-extend char token))
+ ((char= char #\:)
+ (if package
+ (setq internp t)
+ (setq package token
+ token (make-array (length string)
+ :element-type 'character
+ :fill-pointer 0))))
+ (t
+ (vector-push-extend (casify-char char) token))))
+ (values token package internp)))
+
+(defun casify-char (char)
+ "Convert CHAR accoring to readtable-case."
(ecase (readtable-case *readtable*)
- (:preserve string)
- (:upcase (string-upcase string))
- (:downcase (string-downcase string))
- (:invert (multiple-value-bind (lower upper) (determine-case string)
- (cond ((and lower upper) string)
- (lower (string-upcase string))
- (upper (string-downcase string))
- (t string))))))
+ (:preserve char)
+ (:upcase (char-upcase char))
+ (:downcase (char-downcase char))
+ (:invert (if (upper-case-p char)
+ (char-downcase char)
+ (char-upcase char)))))
(defun parse-symbol (string &optional (package *package*))
"Find the symbol named STRING.
Return the symbol and a flag indicating whether the symbols was found."
- (multiple-value-bind (sname pname) (tokenize-symbol string)
+ (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string)
(let ((package (cond ((string= pname "") keyword-package)
- (pname (find-package (casify pname)))
+ (pname (find-package pname))
(t package))))
(if package
- (find-symbol (casify sname) package)
+ (find-symbol sname package)
(values nil nil)))))
(defun parse-symbol-or-lose (string &optional (package *package*))
@@ -1141,17 +1390,14 @@
(multiple-value-bind (name pos)
(if (zerop (length string))
(values :|| 0)
- (let ((*package* keyword-package))
+ (let ((*package* *swank-io-package*))
(ignore-errors (read-from-string string))))
- (if (and (or (keywordp name) (stringp name))
- (= (length string) pos))
- (find-package name))))
+ (and name
+ (or (symbolp name)
+ (stringp name))
+ (= (length string) pos)
+ (find-package name))))
-(defun to-string (string)
- "Write string in the *BUFFER-PACKAGE*."
- (with-buffer-syntax ()
- (prin1-to-string string)))
-
(defun guess-package-from-string (name &optional (default-package *package*))
(or (and name
(or (parse-package name)
@@ -1184,38 +1430,54 @@
;;;; Arglists
-(defslimefun arglist-for-echo-area (names)
+(defun find-valid-operator-name (names)
+ "As a secondary result, returns its index."
+ (let ((index
+ (position-if (lambda (name)
+ (or (consp name)
+ (valid-operator-name-p name)))
+ names)))
+ (if index
+ (values (elt names index) index)
+ (values nil nil))))
+
+(defslimefun arglist-for-echo-area (names &key print-right-margin
+ print-lines arg-indices)
"Return the arglist for the first function, macro, or special-op in NAMES."
(handler-case
(with-buffer-syntax ()
- (let ((name (find-if #'valid-operator-name-p names)))
- (if name (format-arglist-for-echo-area (parse-symbol name) name))))
+ (multiple-value-bind (name which)
+ (find-valid-operator-name names)
+ (when which
+ (let ((arg-index (and arg-indices (elt arg-indices which))))
+ (multiple-value-bind (form operator-name)
+ (operator-designator-to-form name)
+ (let ((*print-right-margin* print-right-margin))
+ (format-arglist-for-echo-area
+ form operator-name
+ :print-right-margin print-right-margin
+ :print-lines print-lines
+ :highlight (and arg-index
+ (not (zerop arg-index))
+ ;; don't highlight the operator
+ arg-index))))))))
(error (cond)
(format nil "ARGLIST: ~A" cond))))
-(defun format-arglist-for-echo-area (symbol name)
- "Return SYMBOL's arglist as string for display in the echo area.
-Use the string NAME as operator name."
- (let ((arglist (arglist symbol)))
- (etypecase arglist
- ((member :not-available)
- nil)
- (list
- (let ((enriched-arglist
- (if (extra-keywords symbol)
- ;; When there are extra keywords, we decode the
- ;; arglist, merge in the keywords and encode it
- ;; again.
- (let ((decoded-arglist (decode-arglist arglist)))
- (enrich-decoded-arglist-with-extra-keywords
- decoded-arglist (list symbol))
- (encode-arglist decoded-arglist))
- ;; Otherwise, just use the original arglist.
- ;; This works better for implementation-specific
- ;; lambda-list-keywords like CMUCL's &parse-body.
- arglist)))
- (arglist-to-string (cons name enriched-arglist)
- (symbol-package symbol)))))))
+(defun operator-designator-to-form (name)
+ (etypecase name
+ (cons
+ (destructure-case name
+ ((:make-instance class-name operator-name &rest args)
+ (let ((parsed-operator-name (parse-symbol operator-name)))
+ (values `(,parsed-operator-name ,@args ',(parse-symbol class-name))
+ operator-name)))
+ ((:defmethod generic-name)
+ (values `(defmethod ,(parse-symbol generic-name))
+ 'defmethod))))
+ (string
+ (values `(,(parse-symbol name))
+ name))))
(defun clean-arglist (arglist)
"Remove &whole, &enviroment, and &aux elements from ARGLIST."
@@ -1226,47 +1488,115 @@
'())
(t (cons (car arglist) (clean-arglist (cdr arglist))))))
-(defun arglist-to-string (arglist package)
- "Print the list ARGLIST for display in the echo area.
-The argument name are printed without package qualifiers and
-pretty printing of (function foo) as #'foo is suppressed."
- (setq arglist (clean-arglist arglist))
- (etypecase arglist
- (null "()")
- (cons
- (with-output-to-string (*standard-output*)
- (with-standard-io-syntax
- (let ((*package* package) (*print-case* :downcase)
- (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
- (*print-level* 10) (*print-length* 20))
- (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (loop
- (let ((arg (pop arglist)))
- (etypecase arg
- (symbol (princ arg))
- (string (princ arg))
- (cons (pprint-logical-block (nil nil :prefix "(" :suffix ")")
- (princ (car arg))
- (unless (null (cdr arg))
- (write-char #\space))
- (pprint-fill *standard-output* (cdr arg) nil))))
- (when (null arglist) (return))
- (write-char #\space)
- (pprint-newline :fill))))))))))
+(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
+ provided-args ; list of the provided actual arguments
+ required-args ; list of the required arguments
+ optional-args ; list of the optional arguments
+ key-p ; whether &key appeared
+ keyword-args ; list of the keywords
+ rest ; name of the &rest or &body argument (if any)
+ body-p ; whether the rest argument is a &body
+ allow-other-keys-p ; whether &allow-other-keys appeared
+ aux-args ; list of &aux variables
+ known-junk ; &whole, &environment
+ unknown-junk) ; unparsed stuff
-(defun test-print-arglist (list string)
- (string= (arglist-to-string list (find-package :swank)) string))
+(defun print-arglist (arglist &key operator highlight)
+ (let ((index 0)
+ (need-space nil))
+ (labels ((print-arg (arg)
+ (typecase arg
+ (arglist ; destructuring pattern
+ (print-arglist arg))
+ (optional-arg
+ (princ (encode-optional-arg arg)))
+ (keyword-arg
+ (let ((enc-arg (encode-keyword-arg arg)))
+ (etypecase enc-arg
+ (symbol (princ enc-arg))
+ ((cons symbol)
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (princ (car enc-arg))
+ (write-char #\space)
+ (pprint-fill *standard-output* (cdr enc-arg) nil)))
+ ((cons cons)
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (prin1 (caar enc-arg))
+ (write-char #\space)
+ (print-arg (keyword-arg.arg-name arg)))
+ (unless (null (cdr enc-arg))
+ (write-char #\space))
+ (pprint-fill *standard-output* (cdr enc-arg) nil))))))
+ (t ; required formal or provided actual arg
+ (princ arg))))
+ (print-space ()
+ (ecase need-space
+ ((nil))
+ ((:miser)
+ (write-char #\space)
+ (pprint-newline :miser))
+ ((t)
+ (write-char #\space)
+ (pprint-newline :fill)))
+ (setq need-space t))
+ (print-with-space (obj)
+ (print-space)
+ (print-arg obj))
+ (print-with-highlight (arg &optional (index-ok-p #'=))
+ (print-space)
+ (cond
+ ((and highlight (funcall index-ok-p index highlight))
+ (princ "===> ")
+ (print-arg arg)
+ (princ " <==="))
+ (t
+ (print-arg arg)))
+ (incf index)))
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (when operator
+ (print-with-highlight operator)
+ (setq need-space :miser))
+ (mapc #'print-with-highlight
+ (arglist.provided-args arglist))
+ (mapc #'print-with-highlight
+ (arglist.required-args arglist))
+ (when (arglist.optional-args arglist)
+ (print-with-space '&optional)
+ (mapc #'print-with-highlight
+ (arglist.optional-args arglist)))
+ (when (arglist.key-p arglist)
+ (print-with-space '&key)
+ (mapc #'print-with-space
+ (arglist.keyword-args arglist)))
+ (when (arglist.allow-other-keys-p arglist)
+ (print-with-space '&allow-other-keys))
+ (cond ((not (arglist.rest arglist)))
+ ((arglist.body-p arglist)
+ (print-with-space '&body)
+ (print-with-highlight (arglist.rest arglist) #'<=))
+ (t
+ (print-with-space '&rest)
+ (print-with-highlight (arglist.rest arglist) #'<=)))
+ (mapc #'print-with-space
+ (arglist.unknown-junk arglist))))))
-;; Should work:
-(progn
- (assert (test-print-arglist '(function cons) "(function cons)"))
- (assert (test-print-arglist '(quote cons) "(quote cons)"))
- (assert (test-print-arglist '(&key (function #'+)) "(&key (function #'+))"))
- (assert (test-print-arglist '(&whole x y z) "(y z)"))
- (assert (test-print-arglist '(x &aux y z) "(x)"))
- (assert (test-print-arglist '(x &environment env y) "(x y)")))
-;; Expected failure:
-;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))
+(defun decoded-arglist-to-string (arglist package
+ &key operator print-right-margin
+ print-lines highlight)
+ "Print the decoded ARGLIST for display in the echo area. The
+argument name are printed without package qualifiers and pretty
+printing of (function foo) as #'foo is suppressed. If HIGHLIGHT is
+non-nil, it must be the index of an argument; highlight this argument.
+If OPERATOR is non-nil, put it in front of the arglist."
+ (with-output-to-string (*standard-output*)
+ (with-standard-io-syntax
+ (let ((*package* package) (*print-case* :downcase)
+ (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
+ (*print-level* 10) (*print-length* 20)
+ (*print-right-margin* print-right-margin)
+ (*print-lines* print-lines))
+ (print-arglist arglist :operator operator :highlight highlight)))))
(defslimefun variable-desc-for-echo-area (variable-name)
"Return a short description of VARIABLE-NAME, or NIL."
@@ -1277,6 +1607,17 @@
(*print-length* 10) (*print-circle* t))
(format nil "~A => ~A" sym (symbol-value sym)))))))
+(defun decode-required-arg (arg)
+ "ARG can be a symbol or a destructuring pattern."
+ (etypecase arg
+ (symbol arg)
+ (list (decode-arglist arg))))
+
+(defun encode-required-arg (arg)
+ (etypecase arg
+ (symbol arg)
+ (arglist (encode-arglist arg))))
+
(defstruct (keyword-arg
(:conc-name keyword-arg.)
(:constructor make-keyword-arg (keyword arg-name default-arg)))
@@ -1294,29 +1635,40 @@
((and (consp arg)
(consp (car arg)))
(make-keyword-arg (caar arg)
- (cadar arg)
+ (decode-required-arg (cadar arg))
(cadr arg)))
((consp arg)
(make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
(car arg)
(cadr arg)))
(t
- (error "Bad keyword item of formal argument list"))))
+ (abort-request "Bad keyword item of formal argument list"))))
(defun encode-keyword-arg (arg)
- (if (eql (intern (symbol-name (keyword-arg.arg-name arg))
- keyword-package)
- (keyword-arg.keyword arg))
- (if (keyword-arg.default-arg arg)
- (list (keyword-arg.arg-name arg)
- (keyword-arg.default-arg arg))
- (keyword-arg.arg-name arg))
- (let ((keyword/name (list (keyword-arg.arg-name arg)
- (keyword-arg.keyword arg))))
- (if (keyword-arg.default-arg arg)
- (list keyword/name
- (keyword-arg.default-arg arg))
- (list keyword/name)))))
+ (cond
+ ((arglist-p (keyword-arg.arg-name arg))
+ ;; Destructuring pattern
+ (let ((keyword/name (list (keyword-arg.keyword arg)
+ (encode-required-arg
+ (keyword-arg.arg-name arg)))))
+ (if (keyword-arg.default-arg arg)
+ (list keyword/name
+ (keyword-arg.default-arg arg))
+ (list keyword/name))))
+ ((eql (intern (symbol-name (keyword-arg.arg-name arg))
+ keyword-package)
+ (keyword-arg.keyword arg))
+ (if (keyword-arg.default-arg arg)
+ (list (keyword-arg.arg-name arg)
+ (keyword-arg.default-arg arg))
+ (keyword-arg.arg-name arg)))
+ (t
+ (let ((keyword/name (list (keyword-arg.keyword arg)
+ (keyword-arg.arg-name arg))))
+ (if (keyword-arg.default-arg arg)
+ (list keyword/name
+ (keyword-arg.default-arg arg))
+ (list keyword/name))))))
(progn
(assert (equalp (decode-keyword-arg 'x)
@@ -1339,11 +1691,14 @@
Return an OPTIONAL-ARG structure."
(etypecase arg
(symbol (make-optional-arg arg nil))
- (list (make-optional-arg (car arg) (cadr arg)))))
+ (list (make-optional-arg (decode-required-arg (car arg))
+ (cadr arg)))))
(defun encode-optional-arg (optional-arg)
- (if (optional-arg.default-arg optional-arg)
- (list (optional-arg.arg-name optional-arg)
+ (if (or (optional-arg.default-arg optional-arg)
+ (arglist-p (optional-arg.arg-name optional-arg)))
+ (list (encode-required-arg
+ (optional-arg.arg-name optional-arg))
(optional-arg.default-arg optional-arg))
(optional-arg.arg-name optional-arg)))
@@ -1353,14 +1708,7 @@
(assert (equalp (decode-optional-arg '(x t))
(make-optional-arg 'x t))))
-(defstruct (arglist (:conc-name arglist.))
- required-args ; list of the required arguments
- optional-args ; list of the optional arguments
- key-p ; whether &key appeared
- keyword-args ; list of the keywords
- rest ; name of the &rest or &body argument (if any)
- body-p ; whether the rest argument is a &body
- allow-other-keys-p) ; whether &allow-other-keys appeared
+(define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
(defun decode-arglist (arglist)
"Parse the list ARGLIST and return an ARGLIST structure."
@@ -1368,15 +1716,25 @@
(result (make-arglist)))
(dolist (arg arglist)
(cond
+ ((eql mode '&unknown-junk)
+ ;; don't leave this mode -- we don't know how the arglist
+ ;; after unknown lambda-list keywords is interpreted
+ (push arg (arglist.unknown-junk result)))
((eql arg '&allow-other-keys)
(setf (arglist.allow-other-keys-p result) t))
((eql arg '&key)
(setf (arglist.key-p result) t
mode arg))
+ ((member arg '(&optional &rest &body &aux))
+ (setq mode arg))
+ ((member arg '(&whole &environment))
+ (setq mode arg)
+ (push arg (arglist.known-junk result)))
((member arg lambda-list-keywords)
- (setq mode arg))
+ (setq mode '&unknown-junk)
+ (push arg (arglist.unknown-junk result)))
(t
- (case mode
+ (ecase mode
(&key
(push (decode-keyword-arg arg)
(arglist.keyword-args result)))
@@ -1388,20 +1746,25 @@
(arglist.rest result) arg))
(&rest
(setf (arglist.rest result) arg))
+ (&aux
+ (push (decode-optional-arg arg)
+ (arglist.aux-args result)))
((nil)
- (push arg (arglist.required-args result)))
+ (push (decode-required-arg arg)
+ (arglist.required-args result)))
((&whole &environment)
- (setf mode nil))))))
- (setf (arglist.required-args result)
- (nreverse (arglist.required-args result)))
- (setf (arglist.optional-args result)
- (nreverse (arglist.optional-args result)))
- (setf (arglist.keyword-args result)
- (nreverse (arglist.keyword-args result)))
+ (setf mode nil)
+ (push arg (arglist.known-junk result)))))))
+ (nreversef (arglist.required-args result))
+ (nreversef (arglist.optional-args result))
+ (nreversef (arglist.keyword-args result))
+ (nreversef (arglist.aux-args result))
+ (nreversef (arglist.known-junk result))
+ (nreversef (arglist.unknown-junk result))
result))
(defun encode-arglist (decoded-arglist)
- (append (arglist.required-args decoded-arglist)
+ (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist))
(when (arglist.optional-args decoded-arglist)
'(&optional))
(mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
@@ -1415,7 +1778,11 @@
((arglist.body-p decoded-arglist)
`(&body ,(arglist.rest decoded-arglist)))
(t
- `(&rest ,(arglist.rest decoded-arglist))))))
+ `(&rest ,(arglist.rest decoded-arglist))))
+ (when (arglist.aux-args decoded-arglist)
+ `(&aux ,(arglist.aux-args decoded-arglist)))
+ (arglist.known-junk decoded-arglist)
+ (arglist.unknown-junk decoded-arglist)))
(defun arglist-keywords (arglist)
"Return the list of keywords in ARGLIST.
@@ -1444,61 +1811,73 @@
(methods-keywords
(swank-mop:generic-function-methods generic-function)))
-(defun applicable-methods-keywords (generic-function classes)
+(defun applicable-methods-keywords (generic-function arguments)
"Collect all keywords in the methods of GENERIC-FUNCTION that are
applicable for argument of CLASSES. As a secondary value, return
whether &allow-other-keys appears somewhere."
- (methods-keywords
- (swank-mop:compute-applicable-methods-using-classes
- generic-function classes)))
+ (methods-keywords
+ (multiple-value-bind (amuc okp)
+ (swank-mop:compute-applicable-methods-using-classes
+ generic-function (mapcar #'class-of arguments))
+ (if okp
+ amuc
+ (compute-applicable-methods generic-function arguments)))))
-(defun arglist-to-template-string (arglist package)
- "Print the list ARGLIST for insertion as a template for a function call."
- (decoded-arglist-to-template-string
- (decode-arglist arglist) package))
-
(defun decoded-arglist-to-template-string (decoded-arglist package &key (prefix "(") (suffix ")"))
(with-output-to-string (*standard-output*)
(with-standard-io-syntax
(let ((*package* package) (*print-case* :downcase)
(*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
(*print-level* 10) (*print-length* 20))
- (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
- (print-decoded-arglist-as-template decoded-arglist))))))
+ (print-decoded-arglist-as-template decoded-arglist
+ :prefix prefix
+ :suffix suffix)))))
-(defun print-decoded-arglist-as-template (decoded-arglist)
- (let ((first-p t))
- (flet ((space ()
- (unless first-p
- (write-char #\space)
- (pprint-newline :fill))
- (setq first-p nil)))
- (dolist (arg (arglist.required-args decoded-arglist))
- (space)
- (princ arg))
- (dolist (arg (arglist.optional-args decoded-arglist))
- (space)
- (format t "[~A]" (optional-arg.arg-name arg)))
- (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
- (space)
- (let ((arg-name (keyword-arg.arg-name keyword-arg))
- (keyword (keyword-arg.keyword keyword-arg)))
- (format t "~W ~A"
- (if (keywordp keyword) keyword `',keyword)
- arg-name)))
- (when (and (arglist.rest decoded-arglist)
- (or (not (arglist.keyword-args decoded-arglist))
- (arglist.allow-other-keys-p decoded-arglist)))
- (if (arglist.body-p decoded-arglist)
- (pprint-newline :mandatory)
- (space))
- (format t "~A..." (arglist.rest decoded-arglist)))))
- (pprint-newline :fill))
+(defun print-decoded-arglist-as-template (decoded-arglist &key
+ (prefix "(") (suffix ")"))
+ (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
+ (let ((first-p t))
+ (flet ((space ()
+ (unless first-p
+ (write-char #\space)
+ (pprint-newline :fill))
+ (setq first-p nil))
+ (print-arg-or-pattern (arg)
+ (etypecase arg
+ (symbol (princ arg))
+ (string (princ arg))
+ (list (princ arg))
+ (arglist (print-decoded-arglist-as-template arg)))))
+ (dolist (arg (arglist.required-args decoded-arglist))
+ (space)
+ (print-arg-or-pattern arg))
+ (dolist (arg (arglist.optional-args decoded-arglist))
+ (space)
+ (princ "[")
+ (print-arg-or-pattern (optional-arg.arg-name arg))
+ (princ "]"))
+ (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
+ (space)
+ (let ((arg-name (keyword-arg.arg-name keyword-arg))
+ (keyword (keyword-arg.keyword keyword-arg)))
+ (format t "~W "
+ (if (keywordp keyword) keyword `',keyword))
+ (print-arg-or-pattern arg-name)))
+ (when (and (arglist.rest decoded-arglist)
+ (or (not (arglist.keyword-args decoded-arglist))
+ (arglist.allow-other-keys-p decoded-arglist)))
+ (if (arglist.body-p decoded-arglist)
+ (pprint-newline :mandatory)
+ (space))
+ (format t "~A..." (arglist.rest decoded-arglist)))))
+ (pprint-newline :fill)))
(defgeneric extra-keywords (operator &rest args)
(:documentation "Return a list of extra keywords of OPERATOR (a
-symbol) when applied to the (unevaluated) ARGS. As a secondary value,
-return whether other keys are allowed."))
+symbol) when applied to the (unevaluated) ARGS.
+As a secondary value, return whether other keys are allowed.
+As a tertiary value, return the initial sublist of ARGS that was needed
+to determine the extra keywords."))
(defmethod extra-keywords (operator &rest args)
;; default method
@@ -1508,76 +1887,240 @@
(generic-function-keywords symbol-function)
nil)))
+(defun class-from-class-name-form (class-name-form)
+ (when (and (listp class-name-form)
+ (= (length class-name-form) 2)
+ (eq (car class-name-form) 'quote))
+ (let* ((class-name (cadr class-name-form))
+ (class (find-class class-name nil)))
+ (when (and class
+ (not (swank-mop:class-finalized-p class)))
+ ;; Try to finalize the class, which can fail if
+ ;; superclasses are not defined yet
+ (handler-case (swank-mop:finalize-inheritance class)
+ (program-error (c)
+ (declare (ignore c)))))
+ class)))
+
+(defun extra-keywords/slots (class)
+ (multiple-value-bind (slots allow-other-keys-p)
+ (if (swank-mop:class-finalized-p class)
+ (values (swank-mop:class-slots class) nil)
+ (values (swank-mop:class-direct-slots class) t))
+ (let ((slot-init-keywords
+ (loop for slot in slots append
+ (mapcar (lambda (initarg)
+ (make-keyword-arg
+ initarg
+ (swank-mop:slot-definition-name slot)
+ (swank-mop:slot-definition-initform slot)))
+ (swank-mop:slot-definition-initargs slot)))))
+ (values slot-init-keywords allow-other-keys-p))))
+
+(defun extra-keywords/make-instance (operator &rest args)
+ (declare (ignore operator))
+ (unless (null args)
+ (let* ((class-name-form (car args))
+ (class (class-from-class-name-form class-name-form)))
+ (when class
+ (multiple-value-bind (slot-init-keywords class-aokp)
+ (extra-keywords/slots class)
+ (multiple-value-bind (allocate-instance-keywords ai-aokp)
+ (applicable-methods-keywords
+ #'allocate-instance (list class))
+ (multiple-value-bind (initialize-instance-keywords ii-aokp)
+ (applicable-methods-keywords
+ #'initialize-instance (list (swank-mop:class-prototype class)))
+ (multiple-value-bind (shared-initialize-keywords si-aokp)
+ (applicable-methods-keywords
+ #'shared-initialize (list (swank-mop:class-prototype class) t))
+ (values (append slot-init-keywords
+ allocate-instance-keywords
+ initialize-instance-keywords
+ shared-initialize-keywords)
+ (or class-aokp ai-aokp ii-aokp si-aokp)
+ (list class-name-form))))))))))
+
+(defun extra-keywords/change-class (operator &rest args)
+ (declare (ignore operator))
+ (unless (null args)
+ (let* ((class-name-form (car args))
+ (class (class-from-class-name-form class-name-form)))
+ (when class
+ (multiple-value-bind (slot-init-keywords class-aokp)
+ (extra-keywords/slots class)
+ (declare (ignore class-aokp))
+ (multiple-value-bind (shared-initialize-keywords si-aokp)
+ (applicable-methods-keywords
+ #'shared-initialize (list (swank-mop:class-prototype class) t))
+ ;; FIXME: much as it would be nice to include the
+ ;; applicable keywords from
+ ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see
+ ;; how to do it: so we punt, always declaring
+ ;; &ALLOW-OTHER-KEYS.
+ (declare (ignore si-aokp))
+ (values (append slot-init-keywords shared-initialize-keywords)
+ t
+ (list class-name-form))))))))
+
+(defmacro multiple-value-or (&rest forms)
+ (if (null forms)
+ nil
+ (let ((first (first forms))
+ (rest (rest forms)))
+ `(let* ((values (multiple-value-list ,first))
+ (primary-value (first values)))
+ (if primary-value
+ (values-list values)
+ (multiple-value-or ,@rest))))))
+
(defmethod extra-keywords ((operator (eql 'make-instance))
&rest args)
- (unless (null args)
- (let ((class-name-form (car args)))
- (when (and (listp class-name-form)
- (= (length class-name-form) 2)
- (eq (car class-name-form) 'quote))
- (let* ((class-name (cadr class-name-form))
- (class (find-class class-name nil)))
- (unless (swank-mop:class-finalized-p class)
- ;; Try to finalize the class, which can fail if
- ;; superclasses are not defined yet
- (handler-case (swank-mop:finalize-inheritance class)
- (program-error (c)
- (declare (ignore c)))))
- (when class
- ;; We have the case (make-instance 'CLASS ...)
- ;; with a known CLASS.
- (multiple-value-bind (slots allow-other-keys-p)
- (if (swank-mop:class-finalized-p class)
- (values (swank-mop:class-slots class) nil)
- (values (swank-mop:class-direct-slots class) t))
- (let ((slot-init-keywords
- (loop for slot in slots append
- (mapcar (lambda (initarg)
- (make-keyword-arg
- initarg
- initarg ; FIXME
- (swank-mop:slot-definition-initform slot)))
- (swank-mop:slot-definition-initargs slot))))
- (initialize-instance-keywords
- (applicable-methods-keywords #'initialize-instance
- (list class))))
- (return-from extra-keywords
- (values (append slot-init-keywords
- initialize-instance-keywords)
- allow-other-keys-p)))))))))
- (call-next-method))
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+(defmethod extra-keywords ((operator (eql 'make-condition))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'error))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'signal))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'warn))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'cerror))
+ &rest args)
+ (multiple-value-bind (keywords aok determiners)
+ (apply #'extra-keywords/make-instance operator
+ (cdr args))
+ (if keywords
+ (values keywords aok
+ (cons (car args) determiners))
+ (call-next-method))))
+
+(defmethod extra-keywords ((operator (eql 'change-class))
+ &rest args)
+ (multiple-value-bind (keywords aok determiners)
+ (apply #'extra-keywords/change-class operator (cdr args))
+ (if keywords
+ (values keywords aok
+ (cons (car args) determiners))
+ (call-next-method))))
+
+(defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords allow-other-keys-p)
+ "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
+ (when keywords
+ (setf (arglist.key-p decoded-arglist) t)
+ (setf (arglist.keyword-args decoded-arglist)
+ (remove-duplicates
+ (append (arglist.keyword-args decoded-arglist)
+ keywords)
+ :key #'keyword-arg.keyword)))
+ (setf (arglist.allow-other-keys-p decoded-arglist)
+ (or (arglist.allow-other-keys-p decoded-arglist)
+ allow-other-keys-p)))
+
(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
- (multiple-value-bind (extra-keywords extra-aok)
+ "Determine extra keywords from the function call FORM, and modify
+DECODED-ARGLIST to include them. As a secondary return value, return
+the initial sublist of ARGS that was needed to determine the extra
+keywords. As a tertiary return value, return whether any enrichment
+was done."
+ (multiple-value-bind (extra-keywords extra-aok determining-args)
(apply #'extra-keywords form)
;; enrich the list of keywords with the extra keywords
- (when extra-keywords
- (setf (arglist.key-p decoded-arglist) t)
- (setf (arglist.keyword-args decoded-arglist)
- (remove-duplicates
- (append (arglist.keyword-args decoded-arglist)
- extra-keywords)
- :key #'keyword-arg.keyword)))
- (setf (arglist.allow-other-keys-p decoded-arglist)
- (or (arglist.allow-other-keys-p decoded-arglist) extra-aok)))
- decoded-arglist)
+ (enrich-decoded-arglist-with-keywords decoded-arglist
+ extra-keywords extra-aok)
+ (values decoded-arglist
+ determining-args
+ (or extra-keywords extra-aok))))
+(defgeneric compute-enriched-decoded-arglist (operator-form argument-forms)
+ (:documentation
+ "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and
+ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords.
+If the arglist is not available, return :NOT-AVAILABLE."))
+
+(defmethod compute-enriched-decoded-arglist (operator-form argument-forms)
+ (let ((arglist (arglist operator-form)))
+ (etypecase arglist
+ ((member :not-available)
+ :not-available)
+ (list
+ (let ((decoded-arglist (decode-arglist arglist)))
+ (enrich-decoded-arglist-with-extra-keywords decoded-arglist
+ (cons operator-form
+ argument-forms)))))))
+
+(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'with-open-file))
+ argument-forms)
+ (declare (ignore argument-forms))
+ (multiple-value-bind (decoded-arglist determining-args)
+ (call-next-method)
+ (let ((first-arg (first (arglist.required-args decoded-arglist)))
+ (open-arglist (compute-enriched-decoded-arglist 'open nil)))
+ (when (and (arglist-p first-arg) (arglist-p open-arglist))
+ (enrich-decoded-arglist-with-keywords
+ first-arg
+ (arglist.keyword-args open-arglist)
+ nil)))
+ (values decoded-arglist determining-args t)))
+
+(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply))
+ argument-forms)
+ (let ((function-name-form (car argument-forms)))
+ (when (and (listp function-name-form)
+ (= (length function-name-form) 2)
+ (member (car function-name-form) '(quote function)))
+ (let ((function-name (cadr function-name-form)))
+ (when (valid-operator-symbol-p function-name)
+ (let ((function-arglist
+ (compute-enriched-decoded-arglist function-name
+ (cdr argument-forms))))
+ (return-from compute-enriched-decoded-arglist
+ (values (make-arglist :required-args
+ (list 'function)
+ :optional-args
+ (append
+ (mapcar #'(lambda (arg)
+ (make-optional-arg arg nil))
+ (arglist.required-args function-arglist))
+ (arglist.optional-args function-arglist))
+ :key-p
+ (arglist.key-p function-arglist)
+ :keyword-args
+ (arglist.keyword-args function-arglist)
+ :rest
+ 'args
+ :allow-other-keys-p
+ (arglist.allow-other-keys-p function-arglist))
+ (list function-name-form)
+ t)))))))
+ (call-next-method))
+
(defslimefun arglist-for-insertion (name)
(with-buffer-syntax ()
(let ((symbol (parse-symbol name)))
(cond
((and symbol
(valid-operator-name-p name))
- (let ((arglist (arglist symbol)))
- (etypecase arglist
- ((member :not-available)
- :not-available)
- (list
- (let ((decoded-arglist (decode-arglist arglist)))
- (enrich-decoded-arglist-with-extra-keywords decoded-arglist
- (list symbol))
- (decoded-arglist-to-template-string decoded-arglist
- *buffer-package*))))))
+ (let ((decoded-arglist
+ (compute-enriched-decoded-arglist symbol nil)))
+ (if (eql decoded-arglist :not-available)
+ :not-available
+ (decoded-arglist-to-template-string decoded-arglist
+ *buffer-package*))))
(t
:not-available)))))
@@ -1605,36 +2148,270 @@
(arglist.keyword-args decoded-arglist)
:key #'keyword-arg.keyword))))
+(defgeneric form-completion (operator-form argument-forms &key remove-args))
+
+(defmethod form-completion (operator-form argument-forms &key (remove-args t))
+ (when (and (symbolp operator-form)
+ (valid-operator-symbol-p operator-form))
+ (multiple-value-bind (decoded-arglist determining-args any-enrichment)
+ (compute-enriched-decoded-arglist operator-form argument-forms)
+ (etypecase decoded-arglist
+ ((member :not-available)
+ :not-available)
+ (arglist
+ (cond
+ (remove-args
+ ;; get rid of formal args already provided
+ (remove-actual-args decoded-arglist argument-forms))
+ (t
+ ;; replace some formal args by determining actual args
+ (remove-actual-args decoded-arglist determining-args)
+ (setf (arglist.provided-args decoded-arglist)
+ determining-args)))
+ (return-from form-completion
+ (values decoded-arglist any-enrichment))))))
+ :not-available)
+
+(defmethod form-completion ((operator-form (eql 'defmethod))
+ argument-forms &key (remove-args t))
+ (when (and (listp argument-forms)
+ (not (null argument-forms)) ;have generic function name
+ (notany #'listp (rest argument-forms))) ;don't have arglist yet
+ (let* ((gf-name (first argument-forms))
+ (gf (and (or (symbolp gf-name)
+ (and (listp gf-name)
+ (eql (first gf-name) 'setf)))
+ (fboundp gf-name)
+ (fdefinition gf-name))))
+ (when (typep gf 'generic-function)
+ (let ((arglist (arglist gf)))
+ (etypecase arglist
+ ((member :not-available))
+ (list
+ (return-from form-completion
+ (values (make-arglist :provided-args (if remove-args
+ nil
+ (list gf-name))
+ :required-args (list arglist)
+ :rest "body" :body-p t)
+ t))))))))
+ (call-next-method))
+
+(defun read-incomplete-form-from-string (form-string)
+ (with-buffer-syntax ()
+ (handler-case
+ (read-from-string form-string)
+ (reader-error (c)
+ (declare (ignore c))
+ nil)
+ (stream-error (c)
+ (declare (ignore c))
+ nil))))
+
(defslimefun complete-form (form-string)
"Read FORM-STRING in the current buffer package, then complete it
by adding a template for the missing arguments."
+ (let ((form (read-incomplete-form-from-string form-string)))
+ (when (consp form)
+ (let ((operator-form (first form))
+ (argument-forms (rest form)))
+ (let ((form-completion
+ (form-completion operator-form argument-forms)))
+ (unless (eql form-completion :not-available)
+ (return-from complete-form
+ (decoded-arglist-to-template-string form-completion
+ *buffer-package*
+ :prefix ""))))))
+ :not-available))
+
+(defun format-arglist-for-echo-area (form operator-name
+ &key print-right-margin print-lines
+ highlight)
+ "Return the arglist for FORM as a string."
+ (when (consp form)
+ (destructuring-bind (operator-form &rest argument-forms)
+ form
+ (let ((form-completion
+ (form-completion operator-form argument-forms
+ :remove-args nil)))
+ (unless (eql form-completion :not-available)
+ (return-from format-arglist-for-echo-area
+ (decoded-arglist-to-string
+ form-completion
+ *package*
+ :operator operator-name
+ :print-right-margin print-right-margin
+ :print-lines print-lines
+ :highlight highlight))))))
+ nil)
+
+(defun keywords-of-operator (operator)
+ "Return a list of KEYWORD-ARGs that OPERATOR accepts.
+This function is useful for writing EXTRA-KEYWORDS methods for
+user-defined functions which are declared &ALLOW-OTHER-KEYS and which
+forward keywords to OPERATOR."
+ (let ((arglist (form-completion operator nil
+ :remove-args nil)))
+ (unless (eql arglist :not-available)
+ (values
+ (arglist.keyword-args arglist)
+ (arglist.allow-other-keys-p arglist)))))
+
+(defun arglist-ref (decoded-arglist operator &rest indices)
+ (cond
+ ((null indices) decoded-arglist)
+ ((not (arglist-p decoded-arglist)) nil)
+ (t
+ (let ((index (first indices))
+ (args (append (and operator
+ (list operator))
+ (arglist.required-args decoded-arglist)
+ (arglist.optional-args decoded-arglist))))
+ (when (< index (length args))
+ (let ((arg (elt args index)))
+ (apply #'arglist-ref arg nil (rest indices))))))))
+
+(defslimefun completions-for-keyword (names keyword-string arg-indices)
(with-buffer-syntax ()
- (handler-case
- (let ((form (read-from-string form-string)))
- (when (consp form)
- (let ((operator-form (first form))
- (argument-forms (rest form)))
- (when (and (symbolp operator-form)
- (valid-operator-symbol-p operator-form))
- (let ((arglist (arglist operator-form)))
- (etypecase arglist
- ((member :not-available)
- :not-available)
- (list
- (let ((decoded-arglist (decode-arglist arglist)))
- (enrich-decoded-arglist-with-extra-keywords decoded-arglist form)
- ;; get rid of formal args already provided
- (remove-actual-args decoded-arglist argument-forms)
- (return-from complete-form
- (decoded-arglist-to-template-string decoded-arglist
- *buffer-package*
- :prefix "")))))))))
- :not-available)
- (reader-error (c)
- (declare (ignore c))
- :not-available))))
+ (multiple-value-bind (name index)
+ (find-valid-operator-name names)
+ (when name
+ (let* ((form (operator-designator-to-form name))
+ (operator-form (first form))
+ (argument-forms (rest form))
+ (arglist
+ (form-completion operator-form argument-forms
+ :remove-args nil)))
+ (unless (eql arglist :not-available)
+ (let* ((indices (butlast (reverse (last arg-indices (1+ index)))))
+ (arglist (apply #'arglist-ref arglist operator-form indices)))
+ (when (and arglist (arglist-p arglist))
+ ;; It would be possible to complete keywords only if we
+ ;; are in a keyword position, but it is not clear if we
+ ;; want that.
+ (let* ((keywords
+ (mapcar #'keyword-arg.keyword
+ (arglist.keyword-args arglist)))
+ (keyword-name
+ (tokenize-symbol keyword-string))
+ (matching-keywords
+ (find-matching-symbols-in-list keyword-name keywords
+ #'compound-prefix-match))
+ (converter (completion-output-symbol-converter keyword-string))
+ (strings
+ (mapcar converter
+ (mapcar #'symbol-name matching-keywords)))
+ (completion-set
+ (format-completion-set strings nil "")))
+ (list completion-set
+ (longest-completion completion-set)))))))))))
+
+(defun arglist-to-string (arglist package &key print-right-margin highlight)
+ (decoded-arglist-to-string (decode-arglist arglist)
+ package
+ :print-right-margin print-right-margin
+ :highlight highlight))
+
+(defun test-print-arglist ()
+ (flet ((test (list string)
+ (let* ((p (find-package :swank))
+ (actual (arglist-to-string list p)))
+ (unless (string= actual string)
+ (warn "Test failed: ~S => ~S~% Expected: ~S"
+ list actual string)))))
+ (test '(function cons) "(function cons)")
+ (test '(quote cons) "(quote cons)")
+ (test '(&key (function #'+)) "(&key (function #'+))")
+ (test '(&whole x y z) "(y z)")
+ (test '(x &aux y z) "(x)")
+ (test '(x &environment env y) "(x y)")
+ (test '(&key ((function f))) "(&key ((function f)))")))
+
+(test-print-arglist)
+
+;;;; Recording and accessing results of computations
+
+(defvar *record-repl-results* t
+ "Non-nil means that REPL results are saved for later lookup.")
+
+(defvar *object-to-presentation-id*
+ (make-weak-key-hash-table :test 'eq)
+ "Store the mapping of objects to numeric identifiers")
+
+(defvar *presentation-id-to-object*
+ (make-weak-value-hash-table :test 'eql)
+ "Store the mapping of numeric identifiers to objects")
+
+(defun clear-presentation-tables ()
+ (clrhash *object-to-presentation-id*)
+ (clrhash *presentation-id-to-object*))
+
+(defvar *presentation-counter* 0 "identifier counter")
+
+(defvar *nil-surrogate* (make-symbol "nil-surrogate"))
+
+;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the
+;; rest of slime isn't thread safe either), do we really care?
+(defun save-presented-object (object)
+ "Save OBJECT and return the assigned id.
+If OBJECT was saved previously return the old id."
+ (let ((object (if (null object) *nil-surrogate* object)))
+ ;; We store *nil-surrogate* instead of nil, to distinguish it from
+ ;; an object that was garbage collected.
+ (or (gethash object *object-to-presentation-id*)
+ (let ((id (incf *presentation-counter*)))
+ (setf (gethash id *presentation-id-to-object*) object)
+ (setf (gethash object *object-to-presentation-id*) id)
+ id))))
+
+(defun lookup-presented-object (id)
+ "Retrieve the object corresponding to ID.
+The secondary value indicates the absence of an entry."
+ (etypecase id
+ (integer
+ ;;
+ (multiple-value-bind (object foundp)
+ (gethash id *presentation-id-to-object*)
+ (cond
+ ((eql object *nil-surrogate*)
+ ;; A stored nil object
+ (values nil t))
+ ((null object)
+ ;; Object that was replaced by nil in the weak hash table
+ ;; when the object was garbage collected.
+ (values nil nil))
+ (t
+ (values object foundp)))))
+ (cons
+ (destructure-case id
+ ((:frame-var frame index)
+ (handler-case
+ (frame-var-value frame index)
+ (t (condition)
+ (declare (ignore condition))
+ (values nil nil))
+ (:no-error (value)
+ (values value t))))
+ ((:inspected-part part-index)
+ (declare (special *inspectee-parts*))
+ (if (< part-index (length *inspectee-parts*))
+ (values (inspector-nth-part part-index) t)
+ (values nil nil)))))))
+
+(defslimefun get-repl-result (id)
+ "Get the result of the previous REPL evaluation with ID."
+ (multiple-value-bind (object foundp) (lookup-presented-object id)
+ (cond (foundp object)
+ (t (abort-request "Attempt to access unrecorded object (id ~D)." id)))))
+
+(defslimefun clear-repl-results ()
+ "Forget the results of all previous REPL evaluations."
+ (clear-presentation-tables)
+ t)
+
+
;;;; Evaluation
(defvar *pending-continuations* '()
@@ -1646,8 +2423,6 @@
(or (guess-package-from-string string nil)
*package*))
-(defvar *current-id* nil)
-
(defun eval-for-emacs (form buffer-package id)
"Bind *BUFFER-PACKAGE* BUFFER-PACKAGE and evaluate FORM.
Return the result to the continuation ID.
@@ -1655,37 +2430,49 @@
(call-with-debugger-hook
#'swank-debugger-hook
(lambda ()
- (let (ok result)
+ (let (ok result reason)
(unwind-protect
(let ((*buffer-package* (guess-buffer-package buffer-package))
(*buffer-readtable* (guess-buffer-readtable buffer-package))
- (*pending-continuations* (cons id *pending-continuations*))
- (*current-id* id))
+ (*pending-continuations* (cons id *pending-continuations*)))
(check-type *buffer-package* package)
(check-type *buffer-readtable* readtable)
- (setq result (eval form))
- (force-output)
- (run-hook *pre-reply-hook*)
- (setq ok t))
+ ;; APPLY would be cleaner than EVAL.
+ ;;(setq result (apply (car form) (cdr form)))
+ (handler-case
+ (progn
+ (setq result (eval form))
+ (run-hook *pre-reply-hook*)
+ (finish-output)
+ (setq ok t))
+ (request-abort (c)
+ (setf ok nil
+ reason (list (slot-value c 'swank-backend::reason))))))
(force-user-output)
(send-to-emacs `(:return ,(current-thread)
- ,(if ok `(:ok ,result) '(:abort))
+ ,(if ok
+ `(:ok ,result)
+ `(:abort ,@reason))
,id)))))))
+(defvar *echo-area-prefix* "=> "
+ "A prefix that `format-values-for-echo-area' should use.")
+
(defun format-values-for-echo-area (values)
(with-buffer-syntax ()
(let ((*print-readably* nil))
(cond ((null values) "; No value")
((and (null (cdr values)) (integerp (car values)))
(let ((i (car values)))
- (format nil "~D (#x~X, #o~O, #b~B)" i i i i)))
- (t (format nil "~{~S~^, ~}" values))))))
+ (format nil "~A~D (#x~X, #o~O, #b~B)"
+ *echo-area-prefix* i i i i)))
+ (t (format nil "~A~{~S~^, ~}" *echo-area-prefix* values))))))
(defslimefun interactive-eval (string)
(with-buffer-syntax ()
(let ((values (multiple-value-list (eval (from-string string)))))
(fresh-line)
- (force-output)
+ (finish-output)
(format-values-for-echo-area values))))
(defslimefun eval-and-grab-output (string)
@@ -1696,6 +2483,7 @@
(list (get-output-stream-string s)
(format nil "~{~S~^~%~}" values)))))
+;;; XXX do we need this stuff? What is it good for?
(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.")
@@ -1738,34 +2526,41 @@
(let ((form (read stream nil stream)))
(when (eq form stream)
(fresh-line)
- (force-output)
+ (finish-output)
(return (values values -)))
(setq - form)
(if *slime-repl-eval-hooks*
- (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
- (if (eq res *slime-repl-eval-hook-pass*)
- (setq values (multiple-value-list (eval form)))
- (setq values res)))
- (setq values (multiple-value-list (eval form))))
- (force-output)))))
+ (setq values (run-repl-eval-hooks form))
+ (setq values (multiple-value-list (eval form))))
+ (finish-output)))))
(when (and package-update-p (not (eq *package* *buffer-package*)))
(send-to-emacs
(list :new-package (package-name *package*)
(package-string-for-prompt *package*))))))
+(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 package-string-for-prompt (package)
"Return the shortest nickname (or canonical name) of PACKAGE."
- (or (canonical-package-nickname package)
- (auto-abbreviated-package-name package)
- (shortest-package-nickname package)))
+ (princ-to-string
+ (make-symbol
+ (or (canonical-package-nickname package)
+ (auto-abbreviated-package-name package)
+ (shortest-package-nickname package)))))
(defun canonical-package-nickname (package)
"Return the canonical package nickname, if any, of PACKAGE."
- (cdr (assoc (package-name package) *canonical-package-nicknames*
- :test #'string=)))
+ (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
+ :test #'string=))))
+ (and name (string name))))
(defun auto-abbreviated-package-name (package)
"Return an abbreviated 'name' for PACKAGE.
@@ -1826,13 +2621,12 @@
(let ((p (setq *package* (guess-package-from-string package))))
(list (package-name p) (package-string-for-prompt p))))
+(defun make-presentations-result (values)
+ ;; overridden in present.lisp
+ `(:present ,(loop for x in values
+ collect (cons (prin1-to-string x)
+ (save-presented-object x)))))
-(defvar *record-repl-results* t
- "Non-nil means that REPL results are saved in *REPL-RESULTS*.")
-
-(defparameter *repl-results* '()
- "Association list of old repl results.")
-
(defslimefun listener-eval (string)
(clear-user-input)
(with-buffer-syntax ()
@@ -1842,56 +2636,41 @@
(unless (or (and (eq values nil) (eq last-form nil))
(eq *slime-repl-advance-history* nil))
(setq *** ** ** * * (car values)
- /// // // / / values)
- (when *record-repl-results*
- (add-repl-result *current-id* *)))
+ /// // // / / values))
(setq +++ ++ ++ + + last-form)
- (if (eq *slime-repl-suppress-output* t)
- ""
- (cond ((null values) "; No value")
- (t
- (format nil "~{~S~^~%~}" values))))))))
+ (cond ((eq *slime-repl-suppress-output* t) '(:suppress-output))
+ (*record-repl-results*
+ (make-presentations-result values))
+ (t
+ `(:values ,(mapcar #'prin1-to-string values))))))))
-(defun add-repl-result (id val)
- (push (cons id val) *repl-results*)
- t)
-
-(defslimefun get-repl-result (id)
- "Get the result of the previous REPL evaluation with ID."
- (let ((previous-output (assoc id *repl-results*)))
- (when (null previous-output)
- (if *record-repl-results*
- (error "Attempt to access no longer existing result (number ~D)." id)
- (error "Attempt to access unrecorded result (number ~D). ~&See ~S."
- id '*record-repl-results*)))
- (cdr previous-output)))
-
-(defslimefun clear-last-repl-result ()
- "Forget the result of the previous REPL evaluation."
- (pop *repl-results*)
- t)
-
-(defslimefun clear-repl-results ()
- "Forget the results of all previous REPL evaluations."
- (setf *repl-results* '()))
- t)
-
(defslimefun ed-in-emacs (&optional what)
"Edit WHAT in Emacs.
WHAT can be:
- A filename (string),
- A list (FILENAME LINE [COLUMN]),
- A function name (symbol),
- nil."
- (let ((target
- (cond ((and (listp what) (pathnamep (first what)))
- (cons (canonicalize-filename (car what)) (cdr what)))
- ((pathnamep what)
- (canonicalize-filename what))
- (t what))))
- (send-oob-to-emacs `(:ed ,target))))
+ A pathname or a string,
+ A list (PATHNAME-OR-STRING LINE [COLUMN]),
+ A function name (symbol or cons),
+ NIL.
+Returns true if it actually called emacs, or NIL if not."
+ (flet ((pathname-or-string-p (thing)
+ (or (pathnamep thing) (typep thing 'string))))
+ (let ((target
+ (cond ((and (listp what) (pathname-or-string-p (first what)))
+ (cons (canonicalize-filename (car what)) (cdr what)))
+ ((pathname-or-string-p what)
+ (canonicalize-filename what))
+ ((symbolp what) what)
+ ((consp what) what)
+ (t (return-from ed-in-emacs nil)))))
+ (cond
+ (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
+ ((default-connection)
+ (with-connection ((default-connection))
+ (send-oob-to-emacs `(:ed ,target))))
+ (t nil)))))
+
(defslimefun value-for-editing (form)
"Return a readable value of FORM for editing in Emacs.
FORM is expected, but not required, to be SETF'able."
@@ -1903,9 +2682,19 @@
"Set the value of a setf'able FORM to VALUE.
FORM and VALUE are both strings from Emacs."
(with-buffer-syntax ()
- (eval `(setf ,(read-from-string form) ,(read-from-string (concatenate 'string "`" value))))
+ (eval `(setf ,(read-from-string form)
+ ,(read-from-string (concatenate 'string "`" value))))
t))
+(defun background-message (format-string &rest args)
+ "Display a message in Emacs' echo area.
+
+Use this function for informative messages only. The message may even
+be dropped, if we are too busy with other things."
+ (when *emacs-connection*
+ (send-to-emacs `(:background-message
+ ,(apply #'format nil format-string args)))))
+
;;;; Debugger
@@ -1928,7 +2717,7 @@
(defun install-debugger (connection)
(declare (ignore connection))
(when *global-debugger*
- (setq *debugger-hook* #'swank-debugger-hook)))
+ (install-debugger-globally #'swank-debugger-hook)))
;;;;; Debugger loop
;;;
@@ -1947,8 +2736,11 @@
"The list of currenlty active restarts.")
(defvar *sldb-stepping-p* nil
- "True when during execution of a stepp command.")
+ "True during execution of a step command.")
+(defvar *sldb-quit-restart* 'abort-request
+ "What restart should swank attempt to invoke when the user sldb-quits.")
+
(defun debug-in-emacs (condition)
(let ((*swank-debugger-condition* condition)
(*sldb-restarts* (compute-restarts condition))
@@ -2082,12 +2874,13 @@
(continue))
(defslimefun throw-to-toplevel ()
- "Use THROW to abort an RPC from Emacs.
+ "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
If we are not evaluating an RPC then ABORT instead."
- (ignore-errors (throw 'slime-toplevel nil))
- ;; If we get here then there was no catch. Try aborting as a fallback.
- ;; That makes the 'q' command in SLDB safer to use with threads.
- (abort))
+ (let ((restart (find-restart *sldb-quit-restart*)))
+ (cond (restart (invoke-restart restart))
+ (t (format nil
+ "Restart not found: ~a"
+ *sldb-quit-restart*)))))
(defslimefun invoke-nth-restart-for-emacs (sldb-level n)
"Invoke the Nth available restart.
@@ -2133,14 +2926,22 @@
(with-buffer-syntax ()
(sldb-break-at-start (read-from-string name))))
-(defslimefun sldb-step (frame)
- (cond ((find-restart 'continue)
+(defmacro define-stepper-function (name backend-function-name)
+ `(defslimefun ,name (frame)
+ (cond ((sldb-stepper-condition-p *swank-debugger-condition*)
+ (setq *sldb-stepping-p* t)
+ (,backend-function-name))
+ ((find-restart 'continue)
(activate-stepping frame)
(setq *sldb-stepping-p* t)
(continue))
(t
- (error "No continue restart."))))
+ (error "Not currently single-stepping, and no continue restart available.")))))
+(define-stepper-function sldb-step sldb-step-into)
+(define-stepper-function sldb-next sldb-step-next)
+(define-stepper-function sldb-out sldb-step-out)
+
;;;; Compilation Commands.
@@ -2195,7 +2996,11 @@
Record compiler notes signalled as `compiler-condition's."
(with-buffer-syntax ()
(let ((*compile-print* nil))
- (swank-compiler (lambda () (swank-compile-file filename load-p))))))
+ (swank-compiler
+ (lambda ()
+ (swank-compile-file filename load-p
+ (or (guess-external-format filename)
+ :default)))))))
(defslimefun compile-string-for-emacs (string buffer position directory)
"Compile STRING (exerpted from BUFFER at POSITION).
@@ -2220,17 +3025,19 @@
(defslimefun list-all-systems-in-central-registry ()
"Returns a list of all systems in ASDF's central registry."
- (loop for dir in (asdf-central-registry)
- for defaults = (eval dir)
- when defaults
- nconc (mapcar #'file-namestring
- (directory
- (make-pathname :defaults defaults
- :version :newest
- :type "asd"
- :name :wild
- :case :local)))))
-
+ (delete-duplicates
+ (loop for dir in (asdf-central-registry)
+ for defaults = (eval dir)
+ when defaults
+ nconc (mapcar #'file-namestring
+ (directory
+ (make-pathname :defaults defaults
+ :version :newest
+ :type "asd"
+ :name :wild
+ :case :local))))
+ :test #'string=))
+
(defun file-newer-p (new-file old-file)
"Returns true if NEW-FILE is newer than OLD-FILE."
(> (file-write-date new-file) (file-write-date old-file)))
@@ -2269,7 +3076,6 @@
(*print-length* . nil)))
(defun apply-macro-expander (expander string)
- (declare (type function expander))
(with-buffer-syntax ()
(with-bindings *macroexpand-printer-bindings*
(prin1-to-string (funcall expander (from-string string))))))
@@ -2283,6 +3089,12 @@
(defslimefun swank-macroexpand-all (string)
(apply-macro-expander #'macroexpand-all string))
+(defslimefun swank-compiler-macroexpand-1 (string)
+ (apply-macro-expander #'compiler-macroexpand-1 string))
+
+(defslimefun swank-compiler-macroexpand (string)
+ (apply-macro-expander #'compiler-macroexpand string))
+
(defslimefun disassemble-symbol (name)
(with-buffer-syntax ()
(with-output-to-string (*standard-output*)
@@ -2326,44 +3138,55 @@
"Return the set of completion-candidates as strings."
(multiple-value-bind (name package-name package internal-p)
(parse-completion-arguments string default-package-name)
- (let* ((symbols (and package
- (find-matching-symbols name
- package
- (and (not internal-p)
- package-name)
- matchp)))
- (packs (and (not package-name)
- (find-matching-packages name matchp)))
- (converter (output-case-converter name))
- (strings
- (mapcar converter
- (nconc (mapcar #'symbol-name symbols) packs))))
- (format-completion-set strings internal-p package-name))))
+ (let* ((symbols (mapcar (completion-output-symbol-converter name)
+ (and package
+ (mapcar #'symbol-name
+ (find-matching-symbols name
+ package
+ (and (not internal-p)
+ package-name)
+ matchp)))))
+ (packs (mapcar (completion-output-package-converter name)
+ (and (not package-name)
+ (find-matching-packages name matchp)))))
+ (format-completion-set (nconc symbols packs) internal-p package-name))))
(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 (output-case-converter string)))
+ (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)
+ (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 symbol-external-p (symbol &optional (package (symbol-package symbol)))
"True if SYMBOL is external in PACKAGE.
If PACKAGE is not specified, the home package of SYMBOL is used."
- (multiple-value-bind (_ status)
- (find-symbol (symbol-name symbol) (or package (symbol-package symbol)))
- (declare (ignore _))
- (eq status :external)))
-
+ (and package
+ (eq (nth-value 1 (find-symbol (symbol-name symbol) package))
+ :external)))
+
(defun find-matching-packages (name matcher)
"Return a list of package names matching NAME with MATCHER.
MATCHER is a two-argument predicate."
@@ -2371,7 +3194,9 @@
(remove-if-not (lambda (x) (funcall matcher to-match x))
(mapcar (lambda (pkgname)
(concatenate 'string pkgname ":"))
- (mapcar #'package-name (list-all-packages))))))
+ (loop for package in (list-all-packages)
+ collect (package-name package)
+ append (package-nicknames package))))))
(defun parse-completion-arguments (string default-package-name)
"Parse STRING as a symbol designator.
@@ -2414,20 +3239,44 @@
(values (concatenate 'string prefix string)
(length prefix))))
-(defun output-case-converter (input)
- "Return a function to case convert strings for output.
+(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 (if (some #'lower-case-p input) #'string-downcase #'identity))
+ (:upcase (cond ((or with-escaping-p
+ (every #'upper-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 (if (some #'upper-case-p input) #'string-upcase #'identity))
+ (:downcase (cond ((or with-escaping-p
+ (every #'lower-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 (some (lambda (el)
+ (member el '(#\: #\. #\ #\Newline #\Tab)))
+ 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."
@@ -2498,8 +3347,10 @@
For example:
\(transpose-lists '((ONE TWO THREE) (1 2)))
=> ((ONE 1) (TWO 2))"
- ;; A cute function from PAIP p.574
- (if lists (apply #'mapcar #'list lists)))
+ (cond ((null lists) '())
+ ((some #'null lists) '())
+ (t (cons (mapcar #'car lists)
+ (transpose-lists (mapcar #'cdr lists))))))
;;;;; Completion Tests
@@ -2524,7 +3375,7 @@
;;;; Fuzzy completion
-(defslimefun fuzzy-completions (string default-package-name &optional limit)
+(defslimefun fuzzy-completions (string default-package-name &key limit time-limit-in-msec)
"Return 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.
@@ -2550,7 +3401,13 @@
FOO - Symbols accessible in the buffer package.
PKG:FOO - Symbols external in package PKG.
PKG::FOO - Symbols accessible in package PKG."
- (fuzzy-completion-set string default-package-name 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).
+ (coerce (fuzzy-completion-set string default-package-name
+ :limit limit :time-limit-in-msec time-limit-in-msec)
+ 'list))
(defun convert-fuzzy-completion-result (result converter
internal-p package-name)
@@ -2562,12 +3419,14 @@
(destructuring-bind (symbol-or-name score chunks) result
(multiple-value-bind (name added-length)
(format-completion-result
- (funcall converter
- (if (symbolp symbol-or-name)
- (symbol-name symbol-or-name)
- symbol-or-name))
+ (if converter
+ (funcall converter
+ (if (symbolp symbol-or-name)
+ (symbol-name symbol-or-name)
+ symbol-or-name))
+ symbol-or-name)
internal-p package-name)
- (list name score
+ (list name score
(mapcar
#'(lambda (chunk)
;; fix up chunk positions to account for possible
@@ -2599,62 +3458,95 @@
)))
collect flag)))))
-(defun fuzzy-completion-set (string default-package-name &optional limit)
+(defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec)
"Prepares list of completion obajects, sorted by SCORE, of fuzzy
completions of STRING in DEFAULT-PACKAGE-NAME. If LIMIT is set,
only the top LIMIT results will be returned."
+ (declare (type (or null (integer 0 #.(1- most-positive-fixnum))) limit time-limit-in-msec))
(multiple-value-bind (name package-name package internal-p)
(parse-completion-arguments string default-package-name)
- (let* ((symbols (and package
- (fuzzy-find-matching-symbols name
- package
- (and (not internal-p)
- package-name))))
- (packs (and (not package-name)
- (fuzzy-find-matching-packages name)))
- (converter (output-case-converter name))
- (results
- (sort (mapcar #'(lambda (result)
- (convert-fuzzy-completion-result
- result converter internal-p package-name))
- (nconc symbols packs))
- #'> :key #'second)))
- (when (and limit
- (> limit 0)
- (< limit (length results)))
- (setf (cdr (nthcdr (1- limit) results)) nil))
- results)))
+ (flet ((convert (vector &optional converter)
+ (when vector
+ (loop for idx :upfrom 0
+ while (< idx (length vector))
+ for el = (aref vector idx)
+ do (setf (aref vector idx) (convert-fuzzy-completion-result
+ el converter internal-p package-name))))))
+ (let* ((symbols (and package
+ (fuzzy-find-matching-symbols name
+ package
+ (and (not internal-p)
+ package-name)
+ :time-limit-in-msec time-limit-in-msec
+ :return-converted-p nil)))
+ (packs (and (not package-name)
+ (fuzzy-find-matching-packages name)))
+ (results))
+ (convert symbols (completion-output-symbol-converter string))
+ (convert packs)
+ (setf results (sort (concatenate 'vector symbols packs) #'> :key #'second))
+ (when (and limit
+ (> limit 0)
+ (< limit (length results)))
+ (if (array-has-fill-pointer-p results)
+ (setf (fill-pointer results) limit)
+ (setf results (make-array limit :displaced-to results))))
+ results))))
-(defun fuzzy-find-matching-symbols (string package external)
+(defun fuzzy-find-matching-symbols (string package external &key time-limit-in-msec return-converted-p)
"Return a list of symbols in PACKAGE matching STRING using the
fuzzy completion algorithm. If EXTERNAL is true, only external
symbols are returned."
- (let ((completions '())
- (converter (output-case-converter string)))
- (flet ((symbol-match (symbol)
+ (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
+ (time-limit (if time-limit-in-msec
+ (ceiling (/ time-limit-in-msec 1000))
+ 0))
+ (utime-at-start (get-universal-time))
+ (count 0)
+ (converter (completion-output-symbol-converter string)))
+ (declare (type (integer 0 #.(1- most-positive-fixnum)) count time-limit)
+ (type function converter))
+ (flet ((symbol-match (symbol converted)
(and (or (not external)
(symbol-external-p symbol package))
- (compute-highest-scoring-completion
- string (funcall converter (symbol-name symbol)) #'char=))))
- (do-symbols (symbol package)
- (multiple-value-bind (result score) (symbol-match symbol)
- (when result
- (push (list symbol score result) completions)))))
- (remove-duplicates completions :key #'first)))
+ (compute-highest-scoring-completion
+ string converted))))
+ (block loop
+ (do-symbols* (symbol package)
+ (incf count)
+ (when (and (not (zerop time-limit))
+ (zerop (mod count 256)) ; ease up on calling get-universal-time like crazy
+ (>= (- (get-universal-time) utime-at-start) time-limit))
+ (return-from loop))
+ (let* ((converted (funcall converter (symbol-name symbol)))
+ (result (if return-converted-p converted symbol)))
+ (if (string= "" string)
+ (when (or (and external (symbol-external-p symbol package))
+ (not external))
+ (vector-push-extend (list result 0.0 (list (list 0 ""))) completions))
+ (multiple-value-bind (match-result score) (symbol-match symbol converted)
+ (when match-result
+ (vector-push-extend (list result score match-result) completions)))))))
+ completions)))
(defun fuzzy-find-matching-packages (name)
"Return a list of package names matching NAME using the fuzzy
completion algorithm."
- (let ((converter (output-case-converter name)))
+ (let ((converter (completion-output-package-converter name))
+ (completions (make-array 32 :adjustable t :fill-pointer 0)))
+ (declare (optimize (speed 3))
+ (type function converter))
(loop for package in (list-all-packages)
for package-name = (concatenate 'string
(funcall converter
(package-name package))
":")
for (result score) = (multiple-value-list
- (compute-highest-scoring-completion
- name package-name #'char=))
- if result collect (list package-name score result))))
+ (compute-highest-scoring-completion
+ name package-name))
+ when result do
+ (vector-push-extend (list package-name score result) completions))
+ completions))
(defslimefun fuzzy-completion-selected (original-string completion)
"This function is called by Slime when a fuzzy completion is
@@ -2680,37 +3572,38 @@
Most natural language searches and symbols do not have this
problem -- this is only here as a safeguard.")
+(declaim (fixnum *fuzzy-recursion-soft-limit*))
-(defun compute-highest-scoring-completion (short full test)
+(defun compute-highest-scoring-completion (short full)
"Finds the highest scoring way to complete the abbreviation
-SHORT onto the string FULL, using TEST as a equality function for
+SHORT onto the string FULL, using CHAR= as a equality function for
letters. Returns two values: The first being the completion
chunks of the high 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 test)))
+ (compute-most-completions short full)))
(winner (first (sort scored-results #'> :key #'first))))
(values (rest winner) (first winner))))
-(defun compute-most-completions (short full test)
+(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))
(declare (special *all-chunks*))
- (recursively-compute-most-completions short full test 0 0 nil nil nil t)
+ (recursively-compute-most-completions short full 0 0 nil nil nil t)
*all-chunks*))
(defun recursively-compute-most-completions
- (short full test
+ (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, with TEST being a
-function to determine if two letters match.
+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,
@@ -2726,7 +3619,10 @@
Once a word has been completely matched, the chunks are pushed
onto the special variable *ALL-CHUNKS* and the function returns."
- (declare (special *all-chunks*))
+ (declare ;;(optimize speed)
+ (fixnum short-index initial-full-index)
+ (simple-string short full)
+ (special *all-chunks*))
(flet ((short-cur ()
"Returns the next letter from the abbreviation, or NIL
if all have been used."
@@ -2755,13 +3651,13 @@
((= pos (length full)))
(let ((cur-char (aref full pos)))
(if (and (short-cur)
- (funcall test cur-char (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 test short-index (1+ pos)
+ short full short-index (1+ pos)
chunks current-chunk current-chunk-pos
(not (> (length *all-chunks*)
*fuzzy-recursion-soft-limit*))))
@@ -2878,6 +3774,48 @@
max-len (highlight-completion result sym) score result))))
+;;;; Completion for character names
+
+(defslimefun completions-for-character (prefix)
+ (let ((completion-set
+ (sort
+ (character-completion-set prefix
+ #'compound-prefix-match/ci/underscores)
+ #'string<)))
+ (list completion-set (longest-completion/underscores completion-set))))
+
+(defun compound-prefix-match/ci/underscores (prefix target)
+ "Like compound-prefix-match, but case-insensitive, and using the underscore,
+not the hyphen, as a delimiter."
+ (declare (type simple-string prefix target))
+ (loop for ch across prefix
+ with tpos = 0
+ always (and (< tpos (length target))
+ (if (char= ch #\_)
+ (setf tpos (position #\_ target :start tpos))
+ (char-equal ch (aref target tpos))))
+ do (incf tpos)))
+
+(defun longest-completion/underscores (completions)
+ "Return the longest prefix for all COMPLETIONS.
+COMPLETIONS is a list of strings."
+ (untokenize-completion/underscores
+ (mapcar #'longest-common-prefix
+ (transpose-lists (mapcar #'tokenize-completion/underscores
+ completions)))))
+
+(defun tokenize-completion/underscores (string)
+ "Return all substrings of STRING delimited by #\_."
+ (loop with end
+ for start = 0 then (1+ end)
+ until (> start (length string))
+ do (setq end (or (position #\_ string :start start) (length string)))
+ collect (subseq string start end)))
+
+(defun untokenize-completion/underscores (tokens)
+ (format nil "~{~A~^_~}" tokens))
+
+
;;;; Documentation
(defslimefun apropos-list-for-emacs (name &optional external-only
@@ -2913,7 +3851,6 @@
"Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
Example:
\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
- (declare (type function test fn))
(apply #'mapcar
(lambda (x) (if (funcall test x) (funcall fn x) x))
lists))
@@ -2921,24 +3858,26 @@
(defun listify (f)
"Return a function like F, but which returns any non-null value
wrapped in a list."
- (declare (type function f))
(lambda (x)
(let ((y (funcall f x)))
(and y (list y)))))
-(defun present-symbol-before-p (a b)
- "Return true if A belongs before B in a printed summary of symbols.
+(defun present-symbol-before-p (x y)
+ "Return true if X belongs before Y in a printed summary of symbols.
Sorted alphabetically by package name and then symbol name, except
that symbols accessible in the current package go first."
+ (declare (type symbol x y))
(flet ((accessible (s)
- (find-symbol (symbol-name s) *buffer-package*)))
- (cond ((and (accessible a) (accessible b))
- (string< (symbol-name a) (symbol-name b)))
- ((accessible a) t)
- ((accessible b) nil)
- (t
- (string< (package-name (symbol-package a))
- (package-name (symbol-package b)))))))
+ ;; Test breaks on NIL for package that does not inherit it
+ (eq (find-symbol (symbol-name s) *buffer-package*) s)))
+ (let ((ax (accessible x)) (ay (accessible y)))
+ (cond ((and ax ay) (string< (symbol-name x) (symbol-name y)))
+ (ax t)
+ (ay nil)
+ (t (let ((px (symbol-package x)) (py (symbol-package y)))
+ (if (eq px py)
+ (string< (symbol-name x) (symbol-name y))
+ (string< (package-name px) (package-name py)))))))))
(let ((regex-hash (make-hash-table :test #'equal)))
(defun compiled-regex (regex-string)
@@ -2946,7 +3885,7 @@
(setf (gethash regex-string regex-hash)
(if (zerop (length regex-string))
(lambda (s) (check-type s string) t)
- (compile nil (nregex:regex-compile regex-string)))))))
+ (compile nil (slime-nregex:regex-compile regex-string)))))))
(defun apropos-matcher (string case-sensitive package external-only)
(let* ((case-modifier (if case-sensitive #'string #'string-upcase))
@@ -3064,7 +4003,7 @@
(format nil "~S is now unprofiled." fname))
(t
(profile fname)
- (format nil "~S is now profiled." fname)))))
+ (format nil "~S is now profiled." fname)))))
;;;; Source Locations
@@ -3090,7 +4029,7 @@
(push e (cdr probe))
(push (cons k (list e)) alist))))
alist))
-
+
(defun location-position< (pos1 pos2)
(cond ((and (position-p pos1) (position-p pos2))
(< (position-pos pos1)
@@ -3099,7 +4038,7 @@
(defun partition (list test key)
(declare (type function test key))
- (loop for e in list
+ (loop for e in list
if (funcall test (funcall key e)) collect e into yes
else collect e into no
finally (return (values yes no))))
@@ -3120,10 +4059,10 @@
(defun group-xrefs (xrefs)
"Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.
The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
- (multiple-value-bind (resolved errors)
+ (multiple-value-bind (resolved errors)
(partition xrefs #'location-valid-p #'xref.location)
(let ((alist (alistify resolved #'xref-buffer #'equal)))
- (append
+ (append
(loop for (buffer . list) in alist
collect (cons (second buffer)
(mapcar (lambda (xref)
@@ -3131,8 +4070,8 @@
(xref.location xref)))
(sort list #'location-position<
:key #'xref-position))))
- (if errors
- (list (cons "Unresolved"
+ (if errors
+ (list (cons "Unresolved"
(mapcar (lambda (xref)
(cons (to-string (xref.dspec xref))
(xref.location xref)))
@@ -3224,9 +4163,13 @@
((and (eq fast slow) (> n 0)) (return nil))
((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
+(defvar *slime-inspect-contents-limit* nil "How many elements of
+ a hash table or array to show by default. If table has more than
+ this then offer actions to view more. Set to nil for no limit." )
+
(defmethod inspect-for-emacs ((ht hash-table) inspector)
(declare (ignore inspector))
- (values "A hash table."
+ (values (prin1-to-string ht)
(append
(label-value-line*
("Count" (hash-table-count ht))
@@ -3235,10 +4178,43 @@
("Rehash size" (hash-table-rehash-size ht))
("Rehash threshold" (hash-table-rehash-threshold ht)))
'("Contents: " (:newline))
+ (if (and *slime-inspect-contents-limit*
+ (>= (hash-table-count ht) *slime-inspect-contents-limit*))
+ (inspect-bigger-piece-actions ht (hash-table-count ht))
+ nil)
(loop for key being the hash-keys of ht
- for value being the hash-values of ht
- append `((:value ,key) " = " (:value ,value) (:newline))))))
+ for value being the hash-values of ht
+ repeat (or *slime-inspect-contents-limit* most-positive-fixnum)
+ append `((:value ,key) " = " (:value ,value) (:newline))))))
+(defmethod inspect-bigger-piece-actions (thing size)
+ (append
+ (if (> size *slime-inspect-contents-limit*)
+ (list (inspect-show-more-action thing)
+ '(:newline))
+ nil)
+ (list (inspect-whole-thing-action thing size)
+ '(:newline))))
+
+(defmethod inspect-whole-thing-action (thing size)
+ `(:action ,(format nil "Inspect all ~a elements."
+ size)
+ ,(lambda()
+ (let ((*slime-inspect-contents-limit* nil))
+ (values
+ (swank::inspect-object thing)
+ :replace)))))
+
+(defmethod inspect-show-more-action (thing)
+ `(:action ,(format nil "~a elements shown. Prompt for how many to inspect..."
+ *slime-inspect-contents-limit* )
+ ,(lambda()
+ (let ((*slime-inspect-contents-limit*
+ (progn (format t "How many elements should be shown? ") (read))))
+ (values
+ (swank::inspect-object thing)
+ :replace)))))
+
(defmethod inspect-for-emacs ((array array) inspector)
(declare (ignore inspector))
(values "An array."
@@ -3251,7 +4227,11 @@
(when (array-has-fill-pointer-p array)
(label-value-line "Fill pointer" (fill-pointer array)))
'("Contents:" (:newline))
- (loop for i below (array-total-size array)
+ (if (and *slime-inspect-contents-limit*
+ (>= (array-total-size array) *slime-inspect-contents-limit*))
+ (inspect-bigger-piece-actions array (length array))
+ nil)
+ (loop for i below (or *slime-inspect-contents-limit* (array-total-size array))
append (label-value-line i (row-major-aref array i))))))
(defmethod inspect-for-emacs ((char character) inspector)
@@ -3290,10 +4270,10 @@
;;
;; Value
(cond ((boundp symbol)
- (label-value-line (if (constantp symbol)
- "It is a constant of value"
- "It is a global variable bound to")
- (symbol-value symbol)))
+ (label-value-line (if (constantp symbol)
+ "It is a constant of value"
+ "It is a global variable bound to")
+ (symbol-value symbol)))
(t '("It is unbound." (:newline))))
(docstring-ispec "Documentation" symbol 'variable)
(multiple-value-bind (expansion definedp) (macroexpand symbol)
@@ -3325,9 +4305,11 @@
" to the package: "
(:value ,package ,(package-name package))
,@(if (eq :internal status)
- `((:action " [export it]"
+ `(" "
+ (:action "[export it]"
,(lambda () (export symbol package)))))
- (:action " [unintern it]"
+ " "
+ (:action "[unintern it]"
,(lambda () (unintern symbol package)))
(:newline))
'("It is a non-interned symbol." (:newline)))
@@ -3339,7 +4321,8 @@
(if (find-class symbol nil)
`("It names the class "
(:value ,(find-class symbol) ,(string symbol))
- (:action " [remove]"
+ " "
+ (:action "[remove]"
,(lambda () (setf (find-class symbol) nil)))
(:newline)))
;;
@@ -3384,29 +4367,19 @@
(defmethod inspect-for-emacs ((o standard-object) inspector)
(declare (ignore inspector))
- (values "An object."
- `("Class: " (:value ,(class-of o))
- (:newline)
- "Slots:" (:newline)
- ,@(loop
- with direct-slots = (swank-mop:class-direct-slots (class-of o))
- for slot in (swank-mop:class-slots (class-of o))
- for slot-def = (or (find-if (lambda (a)
- ;; find the direct slot
- ;; with the same name
- ;; as SLOT (an
- ;; effective slot).
- (eql (swank-mop:slot-definition-name a)
- (swank-mop:slot-definition-name slot)))
- direct-slots)
- slot)
- collect `(:value ,slot-def ,(inspector-princ (swank-mop:slot-definition-name slot-def)))
- collect " = "
- if (slot-boundp o (swank-mop:slot-definition-name slot-def))
- collect `(:value ,(slot-value o (swank-mop:slot-definition-name slot-def)))
- else
- collect "#<unbound>"
- collect '(:newline)))))
+ (let ((c (class-of o)))
+ (values "An object."
+ `("Class: " (:value ,c) (:newline)
+ "Slots:" (:newline)
+ ,@(loop for slotd in (swank-mop:class-slots c)
+ for name = (swank-mop:slot-definition-name slotd)
+ collect `(:value ,slotd ,(string name))
+ collect " = "
+ collect (if (slot-boundp-using-class-for-inspector c o slotd)
+ `(:value ,(slot-value-using-class-for-inspector
+ c o slotd))
+ "#<unbound>")
+ collect '(:newline))))))
(defvar *gf-method-getter* 'methods-by-applicability
"This function is called to get the methods of a generic function.
@@ -3443,8 +4416,42 @@
maxlen
(length doc))))
+(defgeneric slot-value-using-class-for-inspector (class object slot)
+ (:method (class object slot)
+ (swank-mop:slot-value-using-class class object slot)))
+
+(defgeneric slot-boundp-using-class-for-inspector (class object slot)
+ (:method (class object slot)
+ (swank-mop:slot-boundp-using-class class object slot)))
+
+(defgeneric all-slots-for-inspector (object inspector)
+ (:method ((object standard-object) inspector)
+ (declare (ignore inspector))
+ (append '("------------------------------" (:newline)
+ "All Slots:" (:newline))
+ (loop
+ with class = (class-of object)
+ with direct-slots = (swank-mop:class-direct-slots (class-of object))
+ for slot in (swank-mop:class-slots (class-of object))
+ for slot-def = (or (find-if (lambda (a)
+ ;; find the direct slot
+ ;; with the same name
+ ;; as SLOT (an
+ ;; effective slot).
+ (eql (swank-mop:slot-definition-name a)
+ (swank-mop:slot-definition-name slot)))
+ direct-slots)
+ slot)
+ collect `(:value ,slot-def ,(inspector-princ (swank-mop:slot-definition-name slot-def)))
+ collect " = "
+ if (slot-boundp-using-class-for-inspector class object slot)
+ collect `(:value ,(slot-value-using-class-for-inspector
+ (class-of object) object slot))
+ else
+ collect "#<unbound>"
+ collect '(:newline)))))
+
(defmethod inspect-for-emacs ((gf standard-generic-function) inspector)
- (declare (ignore inspector))
(flet ((lv (label value) (label-value-line label value)))
(values
"A generic function."
@@ -3460,14 +4467,16 @@
`((:value ,method ,(inspector-princ
;; drop the name of the GF
(cdr (method-for-inspect-value method))))
- (:action " [remove method]"
+ " "
+ (:action "[remove method]"
,(let ((m method)) ; LOOP reassigns method
(lambda ()
(remove-method gf m))))
- (:newline)))))))
+ (:newline)))
+ `((:newline))
+ (all-slots-for-inspector gf inspector)))))
(defmethod inspect-for-emacs ((method standard-method) inspector)
- (declare (ignore inspector))
(values "A method."
`("Method defined on the generic function "
(:value ,(swank-mop:method-generic-function method)
@@ -3483,10 +4492,11 @@
(:newline)
"Qualifiers: " (:value ,(swank-mop:method-qualifiers method))
(:newline)
- "Method function: " (:value ,(swank-mop:method-function method)))))
+ "Method function: " (:value ,(swank-mop:method-function method))
+ (:newline)
+ ,@(all-slots-for-inspector method inspector))))
(defmethod inspect-for-emacs ((class standard-class) inspector)
- (declare (ignore inspector))
(values "A class."
`("Name: " (:value ,(class-name class))
(:newline)
@@ -3508,8 +4518,9 @@
(swank-mop:slot-definition-name slot)))))
'("#<N/A (class not finalized)>"))
(:newline)
- ,@(when (documentation class t)
- `("Documentation:" (:newline) ,(documentation class t) (:newline)))
+ ,@(let ((doc (documentation class t)))
+ (when doc
+ `("Documentation:" (:newline) ,(inspector-princ doc) (:newline))))
"Sub classes: "
,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
(lambda (sub)
@@ -3540,11 +4551,12 @@
collect '(:newline))))
"Prototype: " ,(if (swank-mop:class-finalized-p class)
`(:value ,(swank-mop:class-prototype class))
- '"#<N/A (class not finalized)>"))))
+ '"#<N/A (class not finalized)>")
+ (:newline)
+ ,@(all-slots-for-inspector class inspector))))
(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) inspector)
- (declare (ignore inspector))
- (values "A slot."
+ (values "A slot."
`("Name: " (:value ,(swank-mop:slot-definition-name slot))
(:newline)
,@(when (swank-mop:slot-definition-documentation slot)
@@ -3555,8 +4567,9 @@
"Init form: " ,(if (swank-mop:slot-definition-initfunction slot)
`(:value ,(swank-mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
- "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
- (:newline))))
+ "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
+ (:newline)
+ ,@(all-slots-for-inspector slot inspector))))
(defmethod inspect-for-emacs ((package package) inspector)
(declare (ignore inspector))
@@ -3625,11 +4638,12 @@
(label-value-line*
("Namestring" (namestring pathname))
("Physical pathname: " (translate-logical-pathname pathname)))
- `("Host: " (pathname-host pathname)
- " (" (:value ,(logical-pathname-translations
- (pathname-host pathname)))
- "other translations)"
- (:newline))
+ `("Host: "
+ ,(pathname-host pathname)
+ " (" (:value ,(logical-pathname-translations
+ (pathname-host pathname)))
+ "other translations)"
+ (:newline))
(label-value-line*
("Directory" (pathname-directory pathname))
("Name" (pathname-name pathname))
@@ -3642,6 +4656,26 @@
(declare (ignore inspector))
(values "A number." `("Value: " ,(princ-to-string n))))
+(defun format-iso8601-time (time-value &optional include-timezone-p)
+ "Formats a universal time TIME-VALUE in ISO 8601 format, with
+ the time zone included if INCLUDE-TIMEZONE-P is non-NIL"
+ ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html
+ ;; Thanks, Nikolai Sandved and Thomas Russ!
+ (flet ((format-iso8601-timezone (zone)
+ (if (zerop zone)
+ "Z"
+ (multiple-value-bind (h m) (truncate (abs zone) 1.0)
+ ;; Tricky. Sign of time zone is reversed in ISO 8601
+ ;; relative to Common Lisp convention!
+ (format nil "~:[+~;-~]~2,'0D:~2,'0D"
+ (> zone 0) h (round (* 60 m)))))))
+ (multiple-value-bind (second minute hour day month year dow dst zone)
+ (decode-universal-time time-value)
+ (declare (ignore dow dst))
+ (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
+ year month day hour minute second
+ include-timezone-p (format-iso8601-timezone zone)))))
+
(defmethod inspect-for-emacs ((i integer) inspector)
(declare (ignore inspector))
(values "A number."
@@ -3654,10 +4688,7 @@
(label-value-line "Length" (integer-length i))
(ignore-errors
(list "As time: "
- (multiple-value-bind (sec min hour date month year)
- (decode-universal-time i)
- (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0DZ"
- year month date hour min sec)))))))
+ (format-iso8601-time i t))))))
(defmethod inspect-for-emacs ((c complex) inspector)
(declare (ignore inspector))
@@ -3687,6 +4718,44 @@
(label-value-line "Digits" (float-digits f))
(label-value-line "Precision" (float-precision f))))))
+(defmethod inspect-for-emacs ((stream file-stream) inspector)
+ (declare (ignore inspector))
+ (multiple-value-bind (title content)
+ (call-next-method)
+ (declare (ignore title))
+ (values "A file stream."
+ (append
+ `("Pathname: "
+ (:value ,(pathname stream))
+ (:newline) " "
+ (:action "[visit file and show current position]"
+ ,(let ((pathname (pathname stream))
+ (position (file-position stream)))
+ (lambda ()
+ (ed-in-emacs `(,pathname :charpos ,position)))))
+ (:newline))
+ content))))
+
+(defmethod inspect-for-emacs ((condition stream-error) inspector)
+ (declare (ignore inspector))
+ (multiple-value-bind (title content)
+ (call-next-method)
+ (let ((stream (stream-error-stream condition)))
+ (if (typep stream 'file-stream)
+ (values "A stream error."
+ (append
+ `("Pathname: "
+ (:value ,(pathname stream))
+ (:newline) " "
+ (:action "[visit file and show current position]"
+ ,(let ((pathname (pathname stream))
+ (position (file-position stream)))
+ (lambda ()
+ (ed-in-emacs `(,pathname :charpos ,position)))))
+ (:newline))
+ content))
+ (values title content)))))
+
(defvar *inspectee*)
(defvar *inspectee-parts*)
(defvar *inspectee-actions*)
@@ -3702,11 +4771,12 @@
*inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0)
*inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
-(defslimefun init-inspector (string)
+(defslimefun init-inspector (string &optional (reset t))
(with-buffer-syntax ()
- (reset-inspector)
+ (when reset
+ (reset-inspector))
(inspect-object (eval (read-from-string string)))))
-
+
(defun print-part-to-string (value)
(let ((string (to-string value))
(pos (position value *inspector-history*)))
@@ -3752,7 +4822,8 @@
(inspect-for-emacs object inspector)
(list :title title
:type (to-string (type-of object))
- :content (inspector-content-for-emacs content)))))
+ :content (inspector-content-for-emacs content)
+ :id (assign-index object *inspectee-parts*)))))
(defslimefun inspector-nth-part (index)
(aref *inspectee-parts* index))
@@ -3761,9 +4832,11 @@
(with-buffer-syntax ()
(inspect-object (inspector-nth-part index))))
-(defslimefun inspector-call-nth-action (index)
- (funcall (aref *inspectee-actions* index))
- (inspect-object (pop *inspector-stack*)))
+(defslimefun inspector-call-nth-action (index &rest args)
+ (multiple-value-bind (value replace) (apply (aref *inspectee-actions* index) args)
+ (if (eq replace :replace)
+ value
+ (inspect-object (pop *inspector-stack*)))))
(defslimefun inspector-pop ()
"Drop the inspector stack and inspect the second element. Return
@@ -3782,6 +4855,9 @@
nil)
(t (inspect-object (aref *inspector-history* (1+ position))))))))
+(defslimefun inspector-reinspect ()
+ (inspect-object *inspectee*))
+
(defslimefun quit-inspector ()
(reset-inspector)
nil)
@@ -3791,6 +4867,11 @@
(with-buffer-syntax ()
(describe-to-string *inspectee*)))
+(defslimefun pprint-inspector-part (index)
+ "Pretty-print the currently inspected object."
+ (with-buffer-syntax ()
+ (swank-pprint (list (inspector-nth-part index)))))
+
(defslimefun inspect-in-frame (string index)
(with-buffer-syntax ()
(reset-inspector)
@@ -3818,7 +4899,8 @@
"Return a list ((NAME DESCRIPTION) ...) of all threads."
(setq *thread-list* (all-threads))
(loop for thread in *thread-list*
- collect (list (thread-name thread)
+ for name = (thread-name thread)
+ collect (list (if (symbolp name) (symbol-name name) name)
(thread-status thread)
(thread-id thread))))
@@ -3903,7 +4985,8 @@
after each command.")
(defslimefun update-indentation-information ()
- (perform-indentation-update *emacs-connection* t))
+ (perform-indentation-update *emacs-connection* t)
+ nil)
;; This function is for *PRE-REPLY-HOOK*.
(defun sync-indentation-to-emacs ()
@@ -3977,7 +5060,7 @@
(defun macro-indentation (arglist)
(if (well-formed-list-p arglist)
- (position '&body (clean-arglist arglist))
+ (position '&body (remove '&optional (clean-arglist arglist)))
nil))
(defun well-formed-list-p (list)
@@ -4013,6 +5096,114 @@
(add-hook *pre-reply-hook* 'sync-indentation-to-emacs)
-;; Local Variables:
-;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
-;; End:
+
+;;;; Presentation menu protocol
+;;
+;; To define a menu for a type of object, define a method
+;; menu-choices-for-presentation on that object type. This function
+;; should return a list of two element lists where the first element is
+;; the name of the menu action and the second is a function that will be
+;; called if the menu is chosen. The function will be called with 3
+;; arguments:
+;;
+;; choice: The string naming the action from above
+;;
+;; object: The object
+;;
+;; id: The presentation id of the object
+;;
+;; You might want append (when (next-method-p) (call-next-method)) to
+;; pick up the Menu actions of superclasses.
+;;
+
+(defvar *presentation-active-menu* nil)
+
+(defun menu-choices-for-presentation-id (id)
+ (multiple-value-bind (ob presentp) (lookup-presented-object id)
+ (cond ((not presentp) 'not-present)
+ (t
+ (let ((menu-and-actions (menu-choices-for-presentation ob)))
+ (setq *presentation-active-menu* (cons id menu-and-actions))
+ (mapcar 'car menu-and-actions))))))
+
+(defun swank-ioify (thing)
+ (cond ((keywordp thing) thing)
+ ((and (symbolp thing)(not (find #\: (symbol-name thing))))
+ (intern (symbol-name thing) 'swank-io-package))
+ ((consp thing) (cons (swank-ioify (car thing)) (swank-ioify (cdr thing))))
+ (t thing)))
+
+(defun execute-menu-choice-for-presentation-id (id count item)
+ (let ((ob (lookup-presented-object id)))
+ (assert (equal id (car *presentation-active-menu*)) ()
+ "Bug: Execute menu call for id ~a but menu has id ~a"
+ id (car *presentation-active-menu*))
+ (let ((action (second (nth (1- count) (cdr *presentation-active-menu*)))))
+ (swank-ioify (funcall action item ob id)))))
+
+;; Default method
+(defmethod menu-choices-for-presentation (ob)
+ (declare (ignore ob))
+ nil)
+
+;; Pathname
+(defmethod menu-choices-for-presentation ((ob pathname))
+ (let* ((file-exists (ignore-errors (probe-file ob)))
+ (lisp-type (make-pathname :type "lisp"))
+ (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal))
+ (let ((source (merge-pathnames lisp-type ob)))
+ (and (ignore-errors (probe-file source))
+ source))))
+ (fasl-file (and file-exists
+ (equal (ignore-errors
+ (namestring
+ (truename
+ (compile-file-pathname
+ (merge-pathnames lisp-type ob)))))
+ (namestring (truename ob))))))
+ (remove nil
+ (list*
+ (and (and file-exists (not fasl-file))
+ (list "Edit this file"
+ (lambda(choice object id)
+ (declare (ignore choice id))
+ (ed-in-emacs (namestring (truename object)))
+ nil)))
+ (and file-exists
+ (list "Dired containing directory"
+ (lambda (choice object id)
+ (declare (ignore choice id))
+ (ed-in-emacs (namestring
+ (truename
+ (merge-pathnames
+ (make-pathname :name "" :type "") object))))
+ nil)))
+ (and fasl-file
+ (list "Load this fasl file"
+ (lambda (choice object id)
+ (declare (ignore choice id object))
+ (load ob)
+ nil)))
+ (and fasl-file
+ (list "Delete this fasl file"
+ (lambda (choice object id)
+ (declare (ignore choice id object))
+ (let ((nt (namestring (truename ob))))
+ (when (y-or-n-p-in-emacs "Delete ~a? " nt)
+ (delete-file nt)))
+ nil)))
+ (and source-file
+ (list "Edit lisp source file"
+ (lambda (choice object id)
+ (declare (ignore choice id object))
+ (ed-in-emacs (namestring (truename source-file)))
+ nil)))
+ (and source-file
+ (list "Load lisp source file"
+ (lambda(choice object id)
+ (declare (ignore choice id object))
+ (load source-file)
+ nil)))
+ (and (next-method-p) (call-next-method))))))
+
+;;; swank.lisp ends here
Modified: trunk/thirdparty/emacs/slime/test-all.sh
===================================================================
--- trunk/thirdparty/emacs/slime/test-all.sh 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/test-all.sh 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,5 +1,8 @@
#!/bin/sh
+# This code has been placed in the Public Domain. All warranties
+# are disclaimed.
+
trap EXIT
for emacs in xemacs ; do # emacs-20.7 emacs-21.3.50 xemacs ; do
Modified: trunk/thirdparty/emacs/slime/test.sh
===================================================================
--- trunk/thirdparty/emacs/slime/test.sh 2006-11-30 14:00:03 UTC (rev 2091)
+++ trunk/thirdparty/emacs/slime/test.sh 2006-11-30 16:32:54 UTC (rev 2092)
@@ -1,6 +1,6 @@
#!/bin/sh
-# Run the SLIME test suite in batch mode, saving the results to a file.
+# Run the SLIME test suite inside screen, saving the results to a file.
# This script's exit status is the number of tests failed. If no tests
# fail then no output is printed. If at least one test fails then a
@@ -9,42 +9,74 @@
# If something unexpected fails, you might get an exit code like 127
# or 255 instead. Sorry.
-if [ $# != 4 ]; then
- echo "Usage: $0 <emacs> <lisp> <dribble-file> <results-file>"
+# This code has been placed in the Public Domain. All warranties
+# are disclaimed.
+
+function usage () {
+ echo "Usage: $name [-v] [-r] <emacs> <lisp>"
exit 1
-fi
+}
-emacs=$1; lisp=$2; dribble=$3; results=$4
-slimedir=$(dirname $0)
+name=$0
+while getopts vr opt; do
+ case $opt in
+ v) verbose=true;;
+ r) dump_results=true;;
+ *) usage;;
+ esac
+done
+
+shift $((OPTIND - 1))
+[ $# = 2 ] || usage
+
+emacs=$1; lisp=$2;
+
# Move the code into a directory in /tmp, so that we can compile it
# for the current lisp.
+slimedir=$(dirname $name)
testdir=/tmp/slime-test.$$
+results=$testdir/results
+dribble=$testdir/dribble
+statusfile=$testdir/status
+
test -d $testdir && rm -r $testdir
+
trap "rm -r $testdir" EXIT # remove temporary directory on exit
mkdir $testdir
cp $slimedir/*.el $slimedir/*.lisp ChangeLog $testdir
+mkfifo $dribble
-# you can remove "--batch" to get an emacs window for troubleshooting.
-$emacs --no-site-file --no-init-file \
- --eval "(setq debug-on-quit t)" \
- --eval "(setq max-lisp-eval-depth 1000)" \
- --eval "(setq load-path (cons \"$testdir\" load-path))" \
- --eval "(require 'slime)" \
- --eval "(setq inferior-lisp-program \"$lisp\")" \
- --eval "(slime-batch-test \"${results}\")" \
- &> $dribble \
+session=slime-screen.$$
-status=$?
+screen -S $session -m -D bash -c "$emacs -nw -q -no-site-file --no-site-file \
+ --eval '(setq debug-on-quit t)' \
+ --eval '(setq max-lisp-eval-depth 1000)' \
+ --eval '(setq load-path (cons \"$testdir\" load-path))' \
+ --eval '(require (quote slime))' \
+ --eval '(setq inferior-lisp-program \"$lisp\")' \
+ --eval '(slime-batch-test \"$results\")' > $dribble;\
+ echo \$? > $statusfile" &
-if [ -f "$results" ]; then
- echo $status "test(s) failed."
+screenpid=$!
+
+if [ "$verbose" = true ]; then
+ cat $dribble &
else
+ cat $dribble > /dev/null &
+fi;
+
+trap "screen -S $session -X quit" SIGINT
+wait $screenpid
+
+if [ -f "$statusfile" ]; then
+ [ "$dump_results" = true ] && cat $results;
+ echo $(cat $statusfile) "test(s) failed."
+else
# Tests crashed
echo crashed
fi
exit $status
-
1
0
[bknr-cvs] r2091 - in branches: . grin grin/bknr grin/bknr/base grin/thirdparty
by bknr＠bknr.net 30 Nov '06
by bknr＠bknr.net 30 Nov '06
30 Nov '06
Author: hhubner
Date: 2006-11-30 09:00:03 -0500 (Thu, 30 Nov 2006)
New Revision: 2091
Added:
branches/grin/
branches/grin/bknr/base/
branches/grin/bknr/base/sysclasses/
branches/grin/thirdparty/
branches/grin/thirdparty/cxml/
Removed:
branches/grin/bknr/base/
branches/grin/bknr/base/sysclasses/
branches/grin/thirdparty/
branches/grin/thirdparty/cxml/
Log:
Add grin branch
Copied: branches/grin (from rev 1738, trunk)
Copied: branches/grin/bknr/base (from rev 1753, trunk/bknr/base)
Copied: branches/grin/bknr/base/sysclasses (from rev 1768, trunk/bknr/base/sysclasses)
Copied: branches/grin/thirdparty (from rev 1753, trunk/thirdparty)
Copied: branches/grin/thirdparty/cxml (from rev 1754, trunk/thirdparty/cxml)
1
0
Author: hhubner
Date: 2006-11-30 08:59:52 -0500 (Thu, 30 Nov 2006)
New Revision: 2090
Removed:
branches/grin/
Log:
remove obsolete branch
1
0
Author: hhubner
Date: 2006-11-30 08:44:21 -0500 (Thu, 30 Nov 2006)
New Revision: 2089
Removed:
branches/trunk/
Log:
not really
1
0
Author: hhubner
Date: 2006-11-30 08:43:35 -0500 (Thu, 30 Nov 2006)
New Revision: 2088
Added:
branches/trunk/
Log:
try again
Copied: branches/trunk (from rev 1738, trunk)
1
0
Author: hhubner
Date: 2006-11-30 08:43:01 -0500 (Thu, 30 Nov 2006)
New Revision: 2087
Removed:
branches/grin/trunk/
Log:
wrong name?!
1
0
Author: hhubner
Date: 2006-11-30 08:42:15 -0500 (Thu, 30 Nov 2006)
New Revision: 2086
Added:
branches/grin/trunk/
Log:
Add branch for current grin development version.
Copied: branches/grin/trunk (from rev 1738, trunk)
1
0
[bknr-cvs] r2085 - in trunk/projects/bos/payment-website: infosystem/da templates/da
by bknr＠bknr.net 29 Nov '06
by bknr＠bknr.net 29 Nov '06
29 Nov '06
Author: hhubner
Date: 2006-11-29 04:52:14 -0500 (Wed, 29 Nov 2006)
New Revision: 2085
Added:
trunk/projects/bos/payment-website/templates/da/ueberweisung.xml
Modified:
trunk/projects/bos/payment-website/infosystem/da/messages.js
trunk/projects/bos/payment-website/infosystem/da/satellitenkarte.htm
trunk/projects/bos/payment-website/templates/da/bestellung.xml
trunk/projects/bos/payment-website/templates/da/privacy.xml
trunk/projects/bos/payment-website/templates/da/profil.xml
trunk/projects/bos/payment-website/templates/da/quittung.xml
trunk/projects/bos/payment-website/templates/da/versand_info.xml
trunk/projects/bos/payment-website/templates/da/versand_quittung.xml
Log:
Current danish language version
Modified: trunk/projects/bos/payment-website/infosystem/da/messages.js
===================================================================
--- trunk/projects/bos/payment-website/infosystem/da/messages.js 2006-11-25 17:01:21 UTC (rev 2084)
+++ trunk/projects/bos/payment-website/infosystem/da/messages.js 2006-11-29 09:52:14 UTC (rev 2085)
@@ -1,21 +1,20 @@
-
document.messages = {
- 'Anzahl Sponsoren': 'Number of sponsors': 'Antal sponsorer',
- 'Anzahl verkaufte m²': 'Number of sold m²': 'Antal solgte kvardratmeter ',
- 'Das Laden des Panoramas dauert einen Moment und benötigt Java in Ihrem Browser.<br /><br />Klicken und Ziehen Sie mit der Maus, um sich im Panorama umzusehen!': 'Loading the panoramic view takes a while and requires Java<br /><br />Click and drag with your mouse in order to look around in the image': 'Det tager lidt tid for oversigtskortet at loade og Java er nødvendigt',
- 'Diese Anwendung benötigt Cookies, um zu funktionieren. Bitte schalten Sie Cookies in Ihrem Browser ein.': 'This application requires that cookies are enabled in your browser. Please enable Cookies and try again!<br /><br />Det tager lidt tid for oversigtskortet at loade og Java er nødvendigt':'Denne funktion foresætter at cookies er slået fra i din browser. <br /><br />Slå venligst cookies-funktionen fra og prøv ig',
- 'Dieser m² wurde bisher noch nicht verkauft': 'This m² has not yet been sold.': 'Denne kvardratmeter er endnu ikke solgt.',
- 'Fehler beim Laden der POI-Informationen, bitte probieren Sie es später noch einmal': 'Error loading POI information, please try again later!': 'Fejl ved loading af POI-information, prøv venligst igen senere!',
- 'Land': 'Country': 'Land',
- 'Luftbild': 'Airal picture': 'Luftbillede',
- 'Name': 'Name': 'Navn',
- 'Panorama': 'Panoramic view': 'Panorama oversigt',
- 'Sat-Karte': 'Sat image': 'Satellit billede',
- 'Sponsor-ID': 'Donor ID': 'Donor ID',
- 'Verkaufte m²': 'Sold m²' ,
+ 'Anzahl Sponsoren': 'Antal sponsorer',
+ 'Anzahl verkaufte m²': 'Antal solgte kvardratmeter ',
+ 'Das Laden des Panoramas dauert einen Moment und benötigt Java in Ihrem Browser.<br /><br />Klicken und Ziehen Sie mit der Maus, um sich im Panorama umzusehen!': 'Det tager lidt tid for oversigtskortet at loade og Java er nødvendigt<br /><br />Klik og træk med din mus for at se dig omkring i billedet.',
+ 'Diese Anwendung benötigt Cookies, um zu funktionieren. Bitte schalten Sie Cookies in Ihrem Browser ein.': 'Denne funktion foresætter at cookies er slået fra i din browser. Slå venligst cookies-funktionen fra og prøv igen.',
+ 'Dieser m² wurde bisher noch nicht verkauft': 'Denne kvardratmeter er endnu ikke solgt.',
+ 'Fehler beim Laden der POI-Informationen, bitte probieren Sie es später noch einmal': 'Fejl ved loading af POI-information, prøv venligst igen senere!',
+ 'Land': 'Land',
+ 'Luftbild': 'Luftbillede',
+ 'Name': 'Navn',
+ 'Panorama': 'Panorama oversigt',
+ 'Sat-Karte': 'Satellit billede',
+ 'Sponsor-ID': 'Donor ID',
+ 'Verkaufte m²': 'Solgte m²' ,
'Zu Verkaufen': 'For sale!',
- 'gesponsort': 'donated': 'Solgte kvardratmeter',
- 'meine m²': 'my m²',
+ 'gesponsort': 'donated',
+ 'meine m²': 'mine m²',
'm²-Verkaufsgebiet': 'm² sale area',
'noch nicht verkauft': 'not yet sold',
'seit': 'since',
Modified: trunk/projects/bos/payment-website/infosystem/da/satellitenkarte.htm
===================================================================
--- trunk/projects/bos/payment-website/infosystem/da/satellitenkarte.htm 2006-11-25 17:01:21 UTC (rev 2084)
+++ trunk/projects/bos/payment-website/infosystem/da/satellitenkarte.htm 2006-11-29 09:52:14 UTC (rev 2085)
@@ -1,4 +1,4 @@
-<?xml version="1.0" encoding="utf-8"?>
+<?xml version="1.0" encoding="utf-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html>
@@ -127,7 +127,7 @@
<table width="138" border="0" cellspacing="0" cellpadding="0">
<tr>
<td class="InfoZelleKennwort">
- <a class="FaehnchenLink" href="#" onclick="document.location.href = '/en/profil'">
+ <a class="FaehnchenLink" href="#" onclick="document.location.href = '/da/profil'">
<img src="/images/pfeil_link_on.gif" border="0"/>
Profil
</a>
Modified: trunk/projects/bos/payment-website/templates/da/bestellung.xml
===================================================================
--- trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-11-25 17:01:21 UTC (rev 2084)
+++ trunk/projects/bos/payment-website/templates/da/bestellung.xml 2006-11-29 09:52:14 UTC (rev 2085)
@@ -1,6 +1,6 @@
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" >
-<bknr:toplevel title="Regnskov i SAMBOJA LESTARI" xmlns="http://www.w3.org/1999/xhtml" xmlns:bknr="http://bknr.net" xmlns:bos="http://headcraft.de/bos">
+<bknr:toplevel title="REGNSKOV i SAMBOJA LESTARI" xmlns="http://www.w3.org/1999/xhtml" xmlns:bknr="http://bknr.net" xmlns:bos="http://headcraft.de/bos">
<!-- content 3teilig-->
<div id="content">
<!-- content left-->
@@ -19,7 +19,7 @@
<td colspan="2">
<span class="link_titlered">
Plant regnskov
- <br></br>for kun 3,- Euro per m²
+ <br></br>for kun 3,- Euro/24,- Kroner per m²
</span>
<br></br><br></br>
</td>
@@ -28,9 +28,9 @@
<tr>
<td></td>
<td colspan="2">
- Vi takker for din beslutning om støtte til Indonesiens folk, natur og dyreliv.
+ Vi takker for din beslutning om stætte til Indonesiens folk, natur og dyreliv.
<br></br><br></br>
- Din støtte er et vigtig bidrag i kampen hen mod at sikre et holdbart projektarbejde i Samboja Lestari.<br></br>
+ Din stætte er et vigtig bidrag i kampen hen mod at sikre et holdbart projektarbejde i Samboja Lestari.<br></br>
<img src="/images/pfeil_link_on.gif" width="10" height="9" alt=""></img>
<a href="idea_subtitle2" class="more">
... mere
@@ -57,6 +57,7 @@
<div id="content_main">
<div id="textbox_content_big">
<form name="bestellformular" method="post" action="buy-sqm">
+ <input type="hidden" name="download-only" value="1"></input>
<table id="formTable" width="100%" border="0" cellspacing="0" cellpadding="0">
<tr>
<td colspan="3">
@@ -71,21 +72,21 @@
<tr>
<td colspan="3">
<input type="radio" name="numsqm" value="1" onclick="document.bestellformular.numsqm1.value = '';"></input>
- 1 m² regnskov [3 Euro],
+ 1 m² regnskov [3 Euro/24 Kroner],
<br></br>
<input type="radio" name="numsqm" value="5" onclick="document.bestellformular.numsqm1.value = '';"></input>
- 5 m² regnskov [15 Euro],
+ 5 m² regnskov [15 Euro/120 Kroner],
<br></br>
<input type="radio" name="numsqm" value="10" checked="checked" onclick="document.bestellformular.numsqm1.value = '';"></input>
- 10 m² regnskov [30 Euro],
+ 10 m² regnskov [30 Euro/240 Kroner],
<br></br>
<input type="radio" name="numsqm" value="30" onclick="document.bestellformular.numsqm1.value = '';"></input>
- 30 m² regnskov [90 Euro],
+ 30 m² regnskov [90 Euro/720 Kroner],
<br></br>
<input type="radio" name="numsqm" value=""></input>
or
<input type="text" name="numsqm1" size="5" value="" onfocus="document.bestellformular.numsqm[4].click()"></input>
- m² [3 Euro stk].
+ m² [3 Euro/24 Kroner stk].
<br></br>
</td>
</tr>
@@ -110,8 +111,7 @@
<tr>
<td colspan="4">
<span class="help_text">
- Din data vil blive behandlet elektronisk af vores partner WorldPay.
- The provisions of the data protection law have been adhered to. Data will not be passed on to third parties.
+ Din data vil blive behandlet elektronisk af vores partner WorldPay. Reglerne for dataloven er blevet overholdt, og ingen data vil blive videregivet til andre.
</span>
<br></br>
<img src="/images/pfeil_link_on.gif" width="10" height="9" alt=""></img>
@@ -126,7 +126,7 @@
<tr>
<td colspan="3">
<span class="help_text">
- Donations can be effected comfortably online via credit card payment.
+ Donationer kan gives nemt og hurtigt online via betaling med kredit kort.
</span>
<!--
Ich möchte den administrativen Aufwand und Kosten für BOS verringern und
@@ -137,19 +137,30 @@
<tr>
<td colspan="3" height="15"> </td>
</tr>
+ <tr>
+ <td colspan="3">
+ <span class="help_text">
+ [Information DanKort]<br></br>Vi kan tilbyde betaling med internationale kreditkort men desværre endnu ikke betaling med DanKort. Hvis du ikke er i besiddelse af et internationalt kreditkort (MasterCard, Visa o.l.), kan du overføre via din bank.
+ </span>
+ </td>
+ </tr>
<tr>
+ <td colspan="3" height="15"> </td>
+ </tr>
+ <tr>
<td colspan="3">
<input type="checkbox" name="disclaimer_read" value="1"></input>
- I have read <img src="/images/pfeil_link_on.gif" width="10" height="9" alt=""></img>
+ Jeg har læst <img src="/images/pfeil_link_on.gif" width="10" height="9" alt=""></img>
<a href="javascript:show_disclaimer()" class="more">
- the waiver clause
- </a> and I agree.<br></br>
+ betingelserne
+ </a> og er enig.<br></br>
<br></br> <br></br>
</td>
</tr>
<tr>
<td align="right" colspan="3">
- <input type="submit" class="form_big_bold" name="action" value="Donate online" onclick="return check_online();"></input>
+ <input type="submit" class="form_big_bold" name="action" value="Doner online" onclick="return check_online();"></input>
+ <input type="submit" class="form_big" name="action" value="Überweisen" onclick="return check_ueberweisung();"></input>
</td>
</tr>
@@ -160,23 +171,22 @@
<div id="content_right">
<div id="helpbox">
<br></br><br></br><br></br>
- [<strong>Rainforest certificate</strong>]
+ [<strong>Regnskovs diplom</strong>]
<br></br>
- Starting with 1 m² only you receive
+ Startende med bare 1 m², modtager du
<img src="/images/pfeil_link_on.gif" width="10" height="9" alt=""></img>
- <a href="javascript:window_extra('certificat')" class="more">our rainforest certificate</a>
- as a pdf-download from your personal sponsor profile.
+ <a href="javascript:window_extra('certificat')" class="more">vores regnskovs diplom</a>
+ som en pdf-fil fra din personlige sponsor-profil.
<br></br><br></br><br></br>
- [<strong>Donation receipt</strong>]
+ [<strong>Donations kvittering</strong>]
<br></br>
- BOS Germany is a tax free registered charity in Germany. Your ability to claim this donation for tax purposes outside of Germany, is dependent upon the laws of your country.
+ BOS Danmark BOS er en godkendt, non-profit organisation. BOS Danmark er ligeledes godkendt efter ligningsloven §8A, §12, stk 3.
<br></br>
-Within your sponsor profile you will find a receipt as a pdf-download.
+På din sponsor-profil vil du finde din kvittering som en pdf-fil.
<br></br> <br></br>
- [<strong>Guarantee of trustworthiness</strong>]<br></br>
- WorldPay is an internationally renowned provider of online payment services.
-Your date will be encoded by WorldPay and deleted immediately after the payment has been carried out succesfully.
+ [<strong>Garanti for troværdighed</strong>]<br></br>
+ WorldPay er en internationalt godkendt udbyder af online betaling. Din information vil blive registreret af WorldPay og derefter slettet straks efter at din betaling er blevet gennemført.
<br></br><br></br>
</div>
Modified: trunk/projects/bos/payment-website/templates/da/privacy.xml
===================================================================
--- trunk/projects/bos/payment-website/templates/da/privacy.xml 2006-11-25 17:01:21 UTC (rev 2084)
+++ trunk/projects/bos/payment-website/templates/da/privacy.xml 2006-11-29 09:52:14 UTC (rev 2085)
@@ -1,43 +1,39 @@
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" >
<bknr:toplevel template="toplevel_extra" title="Regnskov i SAMBOJA LESTARI - Privacy Policy" xmlns="http://www.w3.org/1999/xhtml" xmlns:bknr="http://bknr.net" xmlns:bos="http://headcraft.de/bos">
- <h1 class="extra">Privacy Policy for BOS International e.V.</h1>
+ <h1 class="extra">Privacy Policy for BOS Danmark</h1>
<p class="text_content">
<p>
-The protection of your personal data via electronic processing is strictly regulated,
-and is something BOS Deutschland e.V. takes very seriously.BOS Deutschland e.V.
-is a renowned and not-for-profit foundation complying with the Bundesdatenschutzgesetz
-(German Privacy Policy Law). BOS is registered under no. 502 VR 4228 at the Amtsgericht (county court) in Kiel;
-exemption paper of the Finanzamt (tax office) in Kiel-Nord, no. GL5105.
+Dine personlige data er fuldt beskyttede under hele den elektroniske transaktion. Beskyttelsen af dine data er noget BOS Danmark tager meget alvorligt. BOS er en godkendt, non-profit organisation; registreret under CVR 29076502. BOS Danmark er ligeledes godkendt efter ligningsloven §8A, §12, stk 3.
</p>
<p>
<b>Hvad sker der med dine personlige data?</b>
</p>
<p>
-Når du har besluttet dig for at lave en donation online, vil du blive bedt om at give dine bank-oplysninger. Denne information vil blive behandlet egenhændigt af WorldPay.
+Når du har besluttet dig for at lave en donation online, vil du blive bedt om at give dine bank-oplysninger. Denne information vil blive behandlet egenhændigt af WorldPay.
WorldPay er en anerkendt, international udbyder af online betalling.
Din data vil blive sendt til WorldPay gennem en kodet SSL-forbindelse,
og vil blive slettet straks efter en successfuld transaktion.
BOS International har ellers ingen afgang til din bank-information.
</p>
<p>
-Hver kvardratmeter du sponserer med din donation er linket til din personlige profil. Denne profil består af dit navn, hjemland, antal kvardratmeter du sponserer og datoen for din donation.
-Det er desuden muligt at skrive en personlig hilsen. Alt profil-information (undtagen e-mail addresse og post addresse) vil være tilgængelig til besøgende på vores website. På denne måde promoveres kommunikation og menningsudveksling mellem vores sponsore. Profil information kan altid ændres ved at logge ind med dit password. Ved at gøre dette, er det også muligt at forblive anonym.
+Hver kvardratmeter du sponserer med din donation er linket til din personlige profil. Denne profil består af dit navn, hjemland, antal kvardratmeter du sponserer og datoen for din donation.
+Det er desuden muligt at skrive en personlig hilsen. Alt profil-information (undtagen e-mail addresse og post addresse) vil være tilgængelig til besøgende på vores website. På denne måde promoveres kommunikation og menningsudveksling mellem vores sponsore. Profil information kan altid ændres ved at logge ind med dit password. Ved at gøre dette, er det også muligt at forblive anonym.
</p>
<p>
For at kunne sende dig din personlige profil, indeholdende dit sponsor-ID og password, skal vi bruge din e-mail addresse.
-For at kunne sende dit Regnskovs Diplom med normal post skal vi bruge din post addresse, og navnet på den person diplomet skal udstedes til.
+For at kunne sende dit Regnskovs Diplom med normal post skal vi bruge din post addresse, og navnet på den person diplomet skal udstedes til.
For at kunne modtage vores nyhedsbrev/nyhedher, skal vi bruge din e-mail addresse.
</p>
<p>
-Vi forsikre dig om at din data kun vil blive brugt til administrative og informative formål for BOS international.
-Hvis du på noget tidspunkt ikke længere ønsker at modtage mere information fra os, kan du til hver en tid slette din data fra vores system. In case you do not wish to receive any more information from us, you are able to
+Vi forsikre dig om at din data kun vil blive brugt til administrative og informative formål for BOS international.
+Hvis du på noget tidspunkt ikke længere ønsker at modtage mere information fra os, kan du til hver en tid slette din data fra vores system. In case you do not wish to receive any more information from us, you are able to
delete your data from the system at any time.
-Til dette formål, vær venlig altid at oplyse dit sponsor ID!
+Til dette formål, vær venlig altid at oplyse dit sponsor ID!
</p>
<p>
-Hvis du har flere spørgsmåI vedrørende reglerne om Privacy policy for BOS International
+Hvis du har flere spørgsmåI vedrørende reglerne om Privacy policy for BOS International
send venligst en e-mail til: bos(a)orangutang.dk
</p>
</p>
Modified: trunk/projects/bos/payment-website/templates/da/profil.xml
===================================================================
--- trunk/projects/bos/payment-website/templates/da/profil.xml 2006-11-25 17:01:21 UTC (rev 2084)
+++ trunk/projects/bos/payment-website/templates/da/profil.xml 2006-11-29 09:52:14 UTC (rev 2085)
@@ -104,7 +104,7 @@
<tr>
<td class="Label"></td>
<td class="Input">
- <a class="Link" href="#" onclick="document.location.href = '/infosystem/en/satellitenkarte.htm'">
+ <a class="Link" href="#" onclick="document.location.href = '/infosystem/da/satellitenkarte.htm'">
<img src="/images/pfeil_back.gif" border="0"></img>
tilbage
</a>
Modified: trunk/projects/bos/payment-website/templates/da/quittung.xml
===================================================================
--- trunk/projects/bos/payment-website/templates/da/quittung.xml 2006-11-25 17:01:21 UTC (rev 2084)
+++ trunk/projects/bos/payment-website/templates/da/quittung.xml 2006-11-29 09:52:14 UTC (rev 2085)
@@ -123,7 +123,7 @@
</tr>
<tr>
<td colspan="3" align="right">
- <input type="submit" class="form_big" name="Button" onclick="javascript:return confirm('Is the indicated name correct?');" value="save and continue"></input>
+ <input type="submit" class="form_big" name="Button" onclick="javascript:return confirm('Is the indicated name correct?');" value="save and fortsæt"></input>
</td>
</tr>
</table>
@@ -153,7 +153,7 @@
Regnskovs diplom
</a>
som et pdf-download fra din personlige sponsor profil.
- <br></br><br></br><br></br><br></br><br></br><br></br><br></br>
+ <br /><br /><br /><br /><br /><br />
</div>
</div>
</div>
Added: trunk/projects/bos/payment-website/templates/da/ueberweisung.xml
===================================================================
--- trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2006-11-25 17:01:21 UTC (rev 2084)
+++ trunk/projects/bos/payment-website/templates/da/ueberweisung.xml 2006-11-29 09:52:14 UTC (rev 2085)
@@ -0,0 +1,147 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<bknr:toplevel
+ title="REGENWALD für SAMBOJA LESTARI"
+ xmlns="http://www.w3.org/1999/xhtml"
+ xmlns:bknr="http://bknr.net"
+ xmlns:bos="http://headcraft.de/bos"
+ >
+ <div id="content">
+ <div id="content_left"><!-- content left-->
+ <div id="textbox_left_form">
+ <table border="0" cellpadding="1" cellspacing="0">
+ <tr>
+ <td></td>
+ <td colspan="2">
+ <img src="/images/step3.gif" width="120" height="20" border="0" alt="" />
+ </td>
+ </tr>
+ <tr><td colspan="4" height="40"></td></tr>
+ </table>
+ </div>
+ <!-- footer -->
+ <div id="menue_footer">
+ <a href="javascript:window_extra('privacy')" class="footer">
+ privacy statement
+ </a>
+ l
+ <a href="javascript:window_extra('impressum')" class="footer">
+ imprint
+ </a>
+ </div>
+ <!-- /footer -->
+ </div>
+ <!-- /content left-->
+ <!-- container content_main -->
+ <div id="content_main">
+ <div id="textbox_content_big" >
+ <form action="mail-transfer" method="post"
+ enctype="application/x-www-form-urlencoded"
+ name="mailtransfer"
+ id="mailtransfer"
+ onsubmit="YY_checkform('mailtransfer','vorname','#q','0','Bitte das Feld \'Vorname\' ausfuellen.','name','#q','0','Bitte das Feld \'Name\' ausfuellen.','strasse','#q','0','Bitte das Feld \'Strasse\' ausfuellen.','plz','#q','0','Bitte das Feld \'PLZ\' ausfuellen.','ort','#q','0','Bitte das Feld \'Ort\' ausfuellen.');return document.MM_returnValue">
+ <input type="hidden" name="contract-id" value="$(contract-id)" />
+ <input type="hidden" name="donationcert-yearly" value="$(donationcert-yearly)" />
+ <table id="formTable" width="95%" border="0" cellspacing="0" cellpadding="0">
+ <tr>
+ <td colspan="3"><span class="headline">Ich möchte meine Spende überweisen.</span></td>
+ </tr>
+ <tr>
+ <td colspan="3" height="7"> </td>
+ </tr>
+ <tr>
+ <td colspan="3">
+Ich habe mich dazu entschieden einen Betrag von $(amount) Euro auf das Spendenkonto "Samboja Lestari" von BOS Deutschland e.V. zu überweisen.
+ <table border="0">
+ <tr><td>Kontonummer:</td><td>32 10 100</td></tr>
+ <tr><td>Bank:</td><td>Bank für Sozialwirtschaft</td></tr>
+ <tr><td>BLZ:</td><td>100 205 00</td></tr>
+ </table>
+ <strong>Bitte unbedingt den Verwendungszweck "SL ID $(contract-id)" auf dem Überweisungsformular angeben!</strong>
+ <br /> <br />
+ Meine Überweisung muss ich bei meiner Bank eigenständig veranlassen!
+ </td>
+ </tr>
+ <tr>
+ <td colspan="3" height="7"> </td>
+ </tr>
+ <tr>
+ <td colspan="3" height="7"> </td>
+ </tr>
+ <tr>
+ <td height="10">Vorname:</td>
+ <td width="10"></td>
+ <td><input name="vorname" type="text" size="25" maxlength="30" /></td>
+ </tr>
+ <tr>
+ <td height="10">Name:</td>
+ <td width="10"></td>
+ <td><input name="name" type="text" size="25" maxlength="30" /></td>
+ </tr>
+ <tr>
+ <td height="10">Straße/Nr.:</td>
+ <td width="10"></td>
+ <td><input name="strasse" type="text" size="25" maxlength="30" /></td>
+ </tr>
+ <tr>
+ <td height="10">PLZ/Ort</td>
+ <td width="10"></td>
+ <td>
+ <input name="plz" type="text" size="5" maxlength="5" />
+ <input name="ort" type="text" size="13" maxlength="30" />
+ </td>
+ </tr>
+ <tr>
+ <td height="10">E-Mail:</td>
+ <td width="10"></td>
+ <td><input name="email" type="text" size="25" maxlength="30" /></td>
+ </tr>
+ <tr>
+ <td height="10">Telefon:</td>
+ <td width="10"></td>
+ <td><input name="telefon" type="text" size="25" maxlength="30" /></td>
+ </tr>
+ <tr>
+ <td colspan="3" height="20"> </td>
+ </tr>
+ <tr>
+ <td align="right" colspan="3">
+ <input type="submit" class="form_big" name="action" value="Angaben an BOS mailen" />
+ </td>
+ </tr>
+ </table>
+ </form>
+ </div>
+ </div>
+ <div id="content_right">
+ <div id="helpbox">
+ <strong>[Persönliche Daten]</strong>
+ <br />
+Wir reservieren gerne die von Ihnen gewünschten m². Für die Zusendung
+der entsprechenden Informationen (Regenwaldurkunde, Sponsorenprofil,
+Geokoordinaten, Spendenbescheinigung) benötigen wir unbedingt die
+Angabe Ihrer Daten. Nach erfolgter Überweisung erhalten Sie diese
+Informationen schriftlich oder per E-Mail von uns.
+ <br /><br /><br />
+ <strong>[Dieses Formular]</strong>
+ <br />
+ Bitte senden Sie dieses Formular per E-Mail direkt an uns. Sie können es auch
+ <img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" />
+ <a href="javascript:window.print();" class="more">
+ ausdrucken
+ </a>
+ und per Fax oder Post an unsere
+ Kontaktadresse schicken:
+ <br /><br />
+ BOS Deutschland e.V.
+ <br />
+ Schöneberger Ufer 69
+ <br />
+ 10785 Berlin
+ <br /><br />
+ Fax: (030) 2636 7815
+ </div>
+ </div>
+ </div>
+</bknr:toplevel>
Modified: trunk/projects/bos/payment-website/templates/da/versand_info.xml
===================================================================
--- trunk/projects/bos/payment-website/templates/da/versand_info.xml 2006-11-25 17:01:21 UTC (rev 2084)
+++ trunk/projects/bos/payment-website/templates/da/versand_info.xml 2006-11-29 09:52:14 UTC (rev 2085)
@@ -14,7 +14,7 @@
<script src="/static/bos.js" type="text/javascript"><!-- x -->
</script>
<!--<meta http-equiv="content-type" content="text/html; charset=UTF-8" />-->
- <title>RAINFOREST for SAMBOJA LESTARI</title>
+ <title>Regnskov i SAMBOJA LESTARI</title>
</head>
<body>
@@ -26,7 +26,7 @@
</div>
<div id="menue_header_left">
- BOS Foundation
+ Foreningen BOS
</div>
</div>
@@ -45,12 +45,12 @@
<tr><td colspan="4" height="40"></td></tr>
<tr>
<td> </td>
- <td colspan="2"><span class="link_titlered">Thank you</span><br /><br /></td>
+ <td colspan="2"><span class="link_titlered">Tak</span><br /><br /></td>
<td> </td>
</tr>
<tr>
<td></td>
- <td colspan="2"> for your support and for trusting in BOS. <br /><br />The m² you sponsor are in good hands. </td>
+ <td colspan="2"> for din støtte og for din tilld til BOS. <br /><br />The m² du har sponseret er i gode hænder. </td>
<td></td>
</tr>
</table>
@@ -80,7 +80,7 @@
<input type="hidden" name="next-step-name" value="weiter" />
<table id="formTable" width="95%" border="0" cellspacing="0" cellpadding="0">
<tr>
- <td colspan="3"><span class="headline">Your payment has been successful:</span></td>
+ <td colspan="3"><span class="headline">Din betaling er modtaget:</span></td>
</tr>
<tr>
<td colspan="3" height="140">
@@ -98,12 +98,12 @@
</tr>
<tr>
<td colspan="3">
- Under which name would you like to have your rainforest certificate? [We accept the name entered in this field.]
+ I hvilket navn skal vi udstede dit Regnskovs diplom? [Vi acceptere det intastede navn i dette felt. Vær venlig at ændre navnet om nødvendigt. ]
</td>
</tr>
<tr>
<td height="30">
- Name on the Rainforest certificate:
+ Navn:
</td>
<td></td>
<td>
@@ -115,7 +115,7 @@
</tr>
<tr>
<td colspan="3">
- Please correct the indicated address if necessary for printing into your rainforest certificate:
+ Ret venligst den angivende addresse hvis nødvendigt inden skabelsen af dit regnskovs diplom:
</td>
</tr>
<tr>
@@ -123,7 +123,7 @@
</tr>
<tr>
<td>
- Address<br />for your Rainforest certificate::<br /><br /><br /></td>
+ Addressen til dit <br />regnskovs diplom:<br /><br /><br /></td>
<td></td>
<td>
<!-- left-aligned in order to aid formatting -->
@@ -156,22 +156,21 @@
<div id="content_right">
<div id="helpbox">
<br /><br />
- [<strong>Payment confirmation</strong>]<br />
- This payment confirmation by WorldPay is already under way to your e-mail account.
-In the unexpected case that you will not receive a message please contact
+ [<strong>Betalings-bekræftigelse</strong>]<br />
+ Denne betalings-bekræftigelse fra WorldPay er allerede undervejs til din indbox. I den uventede situation at du ikke skulle modtage nogen besked, venligst kontakt:
<br />
<img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" />
<a href="mailto:service@create-rainforest.org" class="more">
service(a)create-rainforest.org
</a>
<br /><br /><br /><br /><br /><br /><br /><br /><br />
- [<strong>Rainforest certificate</strong>]<br />
- Starting with 1 m² only you receive
+ [<strong>Regnskovs diplom</strong>]<br />
+ Med bare 1 sponseret kvardratmeter vil du modtage vores
<img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" />
<a href="javascript:window_extra('certificat')" class="more">
- a Rainforest certificate
+ Regnskovs diplom
</a>
- from your personal sponsor profile as a pdf-download. If you have any problems or questions please contact
+ som et pdf-download fra din personlige sponsor profil.
<br />
<img src="/images/pfeil_link_on.gif" width="10" height="9" alt="" />
<a href="mailto:service@create-rainforest.org" class="more">
Modified: trunk/projects/bos/payment-website/templates/da/versand_quittung.xml
===================================================================
--- trunk/projects/bos/payment-website/templates/da/versand_quittung.xml 2006-11-25 17:01:21 UTC (rev 2084)
+++ trunk/projects/bos/payment-website/templates/da/versand_quittung.xml 2006-11-29 09:52:14 UTC (rev 2085)
@@ -2,7 +2,7 @@
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<bknr:toplevel
- title="RAINFOREST for SAMBOJA LESTARI"
+ title="REGNSKOV i SAMBOJA LESTARI"
xmlns="http://www.w3.org/1999/xhtml"
xmlns:bknr="http://bknr.net"
xmlns:bos="http://headcraft.de/bos"
@@ -50,11 +50,11 @@
<table id="formTable" width="95%" border="0" cellspacing="0" cellpadding="0">
<tr>
<td colspan="3">
- We will issue the Rainforest Certificate in the following name at the following address:
+ Regnskovs diplomet vil blive udstedt i følgende navn og adresse:
<br /><br /><br />
- Name on the Rainforest Certificate: $(name)
+ Navn på regnskovs diplomet: $(name)
<br /><br />
- Address for the certificate: <br />
+ Adresse på diplomet: <br />
<pre>
$(address)
$(postcode)
@@ -69,7 +69,7 @@
<tr>
<td colspan="3">
<span class="help_text">
- Please check that the details given are accurate.
+ Check venligst at den angivne information er korrekt.
</span>
</td>
</tr>
@@ -87,12 +87,12 @@
</tr>
<tr>
<td colspan="3" height="40">
- This payment has created a new sponsor profile with the following sponsor ID:
+ Denne indbetalling har oprettet en ny sponsor profil med følgende sponsor ID:
</td>
</tr>
<tr>
<td height="20" width="40%">
- <strong>Your sponsor ID:</strong>
+ <strong>Din sponsor ID:</strong>
</td>
<td width="15">
</td>
@@ -123,7 +123,7 @@
<tr>
<td colspan="3" align="right">
<input class="form_big" type="button"
- value="back"
+ value="tilbage"
onclick="javascript:history.back()"
id="back" name="back" />
<input type="submit" class="form_big" name="Button" value="$(next-step-name)" />
@@ -137,11 +137,7 @@
<div id="helpbox">
<br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br /><br />
[<strong>Sponsor ID</strong>]<br />
- You can check your sponsored m²
- at any time using your sponsor ID. The ID enables you to easily locate your m².
- Visitors of this website can look at all m² and their personal profiles.
- If you wish to remain anonymous you can restrict access by the use of a password.
- <br /><br /><br /><br /><br /><br />
+ Du kan til en hver tid cheke dine sponsorerede m² ved hjælp af dit sponsor ID. ID'et gør det muligt for dig nemt at lokaliserer dine m². Ligeledes kan besøgende på hjemmesiden se alle m² og de personlige profiler. Hvis du ønsker at forblive anonym kan du begrænse adgangen ved hjælp af et kodeord. <br /><br /><br /><br /><br /><br />
</div>
</div>
</div>
1
0
Author: hhubner
Date: 2006-11-25 12:01:21 -0500 (Sat, 25 Nov 2006)
New Revision: 2084
Modified:
trunk/projects/bos/m2/mail-generator.lisp
Log:
Remove duplicate Content-Type header that prevented sponsor data mail
from being correctly displayed with Thunderbird.
Modified: trunk/projects/bos/m2/mail-generator.lisp
===================================================================
--- trunk/projects/bos/m2/mail-generator.lisp 2006-11-24 14:43:21 UTC (rev 2083)
+++ trunk/projects/bos/m2/mail-generator.lisp 2006-11-25 17:01:21 UTC (rev 2084)
@@ -16,8 +16,8 @@
From: ~A
To: ~A
Subject: ~A
-Content-Type: ~A
-~@[~*~%~]~A"
+~@[Content-Type: ~A
+~]~@[~*~%~]~A"
(format-date-time (get-universal-time) :mail-style t)
*mail-sender*
to
@@ -151,27 +151,28 @@
:tel (param 'tel)))))
(defun mail-contract-data (contract type mime-parts)
+ (let ((parts mime-parts))
+ (unless (contract-download-only-p contract)
+ (setf parts (append parts
+ (list (make-instance 'mime
+ :type "application"
+ :subtype (format nil "pdf; name=\"contract-~A.pdf\"" (store-object-id contract))
+ :encoding :base64
+ :content (file-contents (contract-pdf-pathname contract :print t)))))))
+ (send-system-mail :to (contract-office-email contract)
+ :subject (format nil "~A-Spenderdaten - Sponsor-ID ~D Contract-ID ~D"
+ type
+ (store-object-id (contract-sponsor contract))
+ (store-object-id contract))
+ :content-type nil
+ :more-headers t
+ :text (with-output-to-string (s)
+ (print-mime s
+ (make-instance 'multipart-mime
+ :subtype "mixed"
+ :content parts)
+ t t))))
(unless (contract-download-only-p contract)
- (push (make-instance 'mime
- :type "application"
- :subtype (format nil "pdf; name=\"contract-~A.pdf\"" (store-object-id contract))
- :encoding :base64
- :content (file-contents (contract-pdf-pathname contract :print t)))
- mime-parts))
- (send-system-mail :to (contract-office-email contract)
- :subject (format nil "~A-Spenderdaten - Sponsor-ID ~D Contract-ID ~D"
- type
- (store-object-id (contract-sponsor contract))
- (store-object-id contract))
- :content-type "multipart/mixed"
- :more-headers t
- :text (with-output-to-string (s)
- (print-mime s
- (make-instance 'multipart-mime
- :subtype "mixed"
- :content mime-parts)
- t t)))
- (unless (contract-download-only-p contract)
(delete-file (contract-pdf-pathname contract :print t))))
(defun mail-manual-sponsor-data (req)
1
0
24 Nov '06
Author: hhubner
Date: 2006-11-24 09:43:21 -0500 (Fri, 24 Nov 2006)
New Revision: 2083
Modified:
trunk/projects/bos/payment-website/infosystem/da/messages.js
trunk/projects/bos/payment-website/infosystem/da/satellitenkarte.htm
Log:
Small fixes in satellite application.
Modified: trunk/projects/bos/payment-website/infosystem/da/messages.js
===================================================================
--- trunk/projects/bos/payment-website/infosystem/da/messages.js 2006-11-20 20:55:39 UTC (rev 2082)
+++ trunk/projects/bos/payment-website/infosystem/da/messages.js 2006-11-24 14:43:21 UTC (rev 2083)
@@ -1,23 +1,23 @@
-
-document.messages = {
- 'Anzahl Sponsoren': 'Number of sponsors',
- 'Anzahl verkaufte m²': 'Number of sold m²',
- 'Das Laden des Panoramas dauert einen Moment und benötigt Java in Ihrem Browser.<br /><br />Klicken und Ziehen Sie mit der Maus, um sich im Panorama umzusehen!': 'Loading the panoramic view takes a while and requires Java<br /><br />Click and drag with your mouse in order to look around in the image',
- 'Diese Anwendung benötigt Cookies, um zu funktionieren. Bitte schalten Sie Cookies in Ihrem Browser ein.': 'This application requires that cookies are enabled in your browser. Please enable Cookies and try again!',
- 'Dieser m² wurde bisher noch nicht verkauft': 'This m² has not yet been sold.',
- 'Fehler beim Laden der POI-Informationen, bitte probieren Sie es später noch einmal': 'Error loading POI information, please try again later!',
- 'Land': 'Country',
- 'Luftbild': 'Airal picture',
- 'Name': 'Name',
- 'Panorama': 'Panoramic view',
- 'Sat-Karte': 'Sat image',
- 'Sponsor-ID': 'Donor ID',
- 'Verkaufte m²': 'Sold m²',
- 'Zu Verkaufen': 'For sale!',
- 'gesponsort': 'donated',
- 'meine m²': 'my m²',
- 'm²-Verkaufsgebiet': 'm² sale area',
- 'noch nicht verkauft': 'not yet sold',
- 'seit': 'since',
- 'zu verkaufen!': 'For sale!'
-};
+
+document.messages = {
+ 'Anzahl Sponsoren': 'Number of sponsors': 'Antal sponsorer',
+ 'Anzahl verkaufte m²': 'Number of sold m²': 'Antal solgte kvardratmeter ',
+ 'Das Laden des Panoramas dauert einen Moment und benötigt Java in Ihrem Browser.<br /><br />Klicken und Ziehen Sie mit der Maus, um sich im Panorama umzusehen!': 'Loading the panoramic view takes a while and requires Java<br /><br />Click and drag with your mouse in order to look around in the image': 'Det tager lidt tid for oversigtskortet at loade og Java er nødvendigt',
+ 'Diese Anwendung benötigt Cookies, um zu funktionieren. Bitte schalten Sie Cookies in Ihrem Browser ein.': 'This application requires that cookies are enabled in your browser. Please enable Cookies and try again!<br /><br />Det tager lidt tid for oversigtskortet at loade og Java er nødvendigt':'Denne funktion foresætter at cookies er slået fra i din browser. <br /><br />Slå venligst cookies-funktionen fra og prøv ig',
+ 'Dieser m² wurde bisher noch nicht verkauft': 'This m² has not yet been sold.': 'Denne kvardratmeter er endnu ikke solgt.',
+ 'Fehler beim Laden der POI-Informationen, bitte probieren Sie es später noch einmal': 'Error loading POI information, please try again later!': 'Fejl ved loading af POI-information, prøv venligst igen senere!',
+ 'Land': 'Country': 'Land',
+ 'Luftbild': 'Airal picture': 'Luftbillede',
+ 'Name': 'Name': 'Navn',
+ 'Panorama': 'Panoramic view': 'Panorama oversigt',
+ 'Sat-Karte': 'Sat image': 'Satellit billede',
+ 'Sponsor-ID': 'Donor ID': 'Donor ID',
+ 'Verkaufte m²': 'Sold m²' ,
+ 'Zu Verkaufen': 'For sale!',
+ 'gesponsort': 'donated': 'Solgte kvardratmeter',
+ 'meine m²': 'my m²',
+ 'm²-Verkaufsgebiet': 'm² sale area',
+ 'noch nicht verkauft': 'not yet sold',
+ 'seit': 'since',
+ 'zu verkaufen!': 'For sale!'
+};
Modified: trunk/projects/bos/payment-website/infosystem/da/satellitenkarte.htm
===================================================================
--- trunk/projects/bos/payment-website/infosystem/da/satellitenkarte.htm 2006-11-20 20:55:39 UTC (rev 2082)
+++ trunk/projects/bos/payment-website/infosystem/da/satellitenkarte.htm 2006-11-24 14:43:21 UTC (rev 2083)
@@ -3,7 +3,7 @@
<html>
<head>
- <title>Satellite View - Samboja Lestari</title>
+ <title>Satellit Perspektiv - Samboja Lestari</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" charset="utf-8" />
<meta http-equiv="imagetoolbar" content="no"/>
@@ -51,21 +51,21 @@
<div id="Loginfehler" style="position:absolute; width:138px; height:88px; z-index:21; left: 10px; top: 403px; visibility: hidden;" class="KarteRahmen">
<table width="138" border="0" cellspacing="0" cellpadding="0">
<tr>
- <td colspan="2" class="InfoKopf">Login Error</td>
+ <td colspan="2" class="InfoKopf">Log ind fejl</td>
</tr>
</table>
<div style="position:absolute; width:138px; z-index:21; left: 0px; top: 10px; visibility: inherit;" class="InfoZelle">
- <br/>Error while logging in, please check your sponsor ID and your password or master code.
+ <br/>Fejl opstod ved log ind, check venligst dit sponsor ID og dit kodeord eller hovedkode.
<img src="/images/pfeil_link_on.gif" border="0"/>
<a class="FaehnchenLink" href="#" onclick="document.getElementById('Loginfehler').style.visibility = 'hidden'">
- continue
+ fortsæt
</a>
</div>
</div>
<div id="Anmelden" style="position:absolute; width:138px; height:88px; z-index:20; left: 10px; top: 403px; visibility: hidden;" class="KarteRahmen">
<table width="138" border="0" cellspacing="0" cellpadding="0">
<tr>
- <td colspan="2" class="InfoKopf">"my" m²</td>
+ <td colspan="2" class="InfoKopf">"mine" m²</td>
</tr>
</table>
<div id="AnmeldenInhalt" style="position:absolute; width:138px; z-index:20; left: 0px; top: 10px; visibility: inherit;">
@@ -87,7 +87,7 @@
</tr>
<tr>
<td colspan="2" class="InfoZelle">
- Password
+ Kodeord
</td>
</tr>
<tr>
@@ -108,7 +108,7 @@
<div id="SponsorInfo" style="position:absolute; width:138px; height:78px; z-index:20; left: 10px; top: 413px; visibility: hidden;" class="KarteRahmen">
<table width="138" border="0" cellspacing="0" cellpadding="0">
<tr>
- <td colspan="2" class="InfoKopf">Logged in as</td>
+ <td colspan="2" class="InfoKopf">Logget på som</td>
</tr>
<tr>
<td class="InfoZelle" height="20">
@@ -129,7 +129,7 @@
<td class="InfoZelleKennwort">
<a class="FaehnchenLink" href="#" onclick="document.location.href = '/en/profil'">
<img src="/images/pfeil_link_on.gif" border="0"/>
- Profile
+ Profil
</a>
</td>
</tr>
@@ -137,7 +137,7 @@
<td class="InfoZelleKennwort">
<a class="FaehnchenLink" href="#" onclick="document.form1.submit();">
<img src="/images/pfeil_back.gif" border="0"/>
- Logout
+ Log ud
</a>
</td>
</tr>
@@ -148,7 +148,7 @@
<div id="UebersichtKlein" style="position:absolute; width:138px; height:76px; z-index:10; left: 10px; top: 79px;" class="KarteRahmen">
<table width="138" border="0" cellspacing="0" cellpadding="0">
<tr>
- <td class="InfoKopf">Overview</td>
+ <td class="InfoKopf">Overblik</td>
</tr>
<tr>
<td align="center" valign="middle"><div id="UebersichtPosition" style="position:absolute; width:4px; height:4px; z-index:5"><img src="../bilder/spacer.gif" width="4" height="4" border="0"/></div>
@@ -163,7 +163,7 @@
<div id="Info3" style="position:absolute; width:178px; height:142px; z-index:3; top: 329px; left: 550px; visibility: inherit;" class="KarteRahmen">
<table width="178" border="0" cellspacing="0" cellpadding="0">
<tr>
- <td class="InfoKopf">"Sale" State</td>
+ <td class="InfoKopf">"Salgs" stand</td>
</tr>
<tr>
<td width="166">
@@ -176,7 +176,7 @@
<div id="Info2" style="position:absolute; width:178px; height:107px; z-index:3; top: 205px; left: 550px; visibility: inherit;" class="KarteRahmen">
<table width="178" border="0" cellspacing="0" cellpadding="0">
<tr>
- <td height="30" class="InfoKopf">Samboja Lestari is located on Borneo</td>
+ <td height="30" class="InfoKopf">Samboja Lestari ligger på Borneo</td>
</tr>
<tr>
<td width="160" height="74" align="center" valign="middle"><img src="../bilder/uebersicht_info2.gif" width="178" height="78"/></td>
@@ -186,7 +186,7 @@
<div id="Info1" style="position:absolute; width:178px; height:113px; z-index:14; top: 79px; left: 550px; visibility: inherit;" class="KarteRahmen">
<table width="178" border="0" cellspacing="0" cellpadding="0">
<tr>
- <td height="30" class="InfoKopf">Samboja Lestari is located in Indonesia</td>
+ <td height="30" class="InfoKopf">Samboja Lestari ligger i Indonesien</td>
</tr>
<tr>
<td width="160" height="74" align="center" valign="middle"><img src="../bilder/uebersicht_info1.gif" width="178" height="83"/></td>
@@ -203,7 +203,7 @@
<img src="../bilder/spacer.gif" width="1" height="1"/>
</div>
<div id="Uebersichthome" style="position:absolute; width:140px; height:20px; z-index:6; left: 10px; top: 164px; visibility: inherit;" class="Navigation">
- Points of Interest
+ Interessante punkter
<div id="UebersichtPoiNavi" style="position:absolute; width:125px; height:80px; z-index:7; left: 19px; top: 17px; visibility: inherit;"></div>
</div>
</div>
@@ -274,7 +274,7 @@
<div id="PoiThumb" style="position:absolute; width:178px; height:131px; z-index:3; top: 79px; left: 550px; visibility: inherit;" class="KarteRahmen">
<table width="178" height="131" border="0" cellpadding="0" cellspacing="0">
<tr>
- <td class="InfoKopf">Picture Gallery</td>
+ <td class="InfoKopf">Foto Galleri</td>
</tr>
<tr>
<td align="center" valign="middle"> <table width="174" border="0" cellpadding="0" cellspacing="0">
@@ -299,7 +299,7 @@
<div id="ThumbLink6" style="position:absolute; width:55px; height:55px; z-index:4; top: 73px; left: 117px; visibility: inherit;"><a href="#" onClick="ThumbVergoessern(6)"><img src="../bilder/spacer.gif" width="55" height="55" border="0"/></a></div>
</div>
<div id="home" style="position:absolute; width:140px; height:20px; z-index:6; left: 10px; top: 164px; visibility: inherit;" class="NavigationAktiv">
- Points of Interest
+ Interessante punkter
<div id="PoiNavi" style="position:absolute; width:125px; height:80px; z-index:7; left: 19px; top: 17px; visibility: inherit;"></div>
</div>
</div>
@@ -315,21 +315,21 @@
<div id="LayersMenu" class="KarteRahmen" style="position: absolute; bottom: 31px; right: 1px; z-index: 15; visibility: inherit;">
<table width="90" border="0" cellspacing="0" cellpadding="0">
<tr>
- <td align="center" class="InfoKopf">Layers</td>
+ <td align="center" class="InfoKopf">Lag</td>
</tr>
<tr>
<td valign="top" align="center">
- <a class="LayersMenuItemActive" id="LayerMenu_background" href="#" onclick="toggle_layer('background')">Sat image</a><br/>
+ <a class="LayersMenuItemActive" id="LayerMenu_background" href="#" onclick="toggle_layer('background')">Sat Foto</a><br/>
</td>
</tr>
<tr>
<td valign="top" align="center">
- <a class="LayersMenuItemActive" id="LayerMenu_areas" href="#" onclick="toggle_layer('areas')">Selling areas</a><br/>
+ <a class="LayersMenuItemActive" id="LayerMenu_areas" href="#" onclick="toggle_layer('areas')">Sælgende områder</a><br/>
</td>
</tr>
<tr>
<td valign="top" align="center">
- <a class="LayersMenuItemActive" id="LayerMenu_contracts" href="#" onclick="toggle_layer('contracts')">Current status</a><br/>
+ <a class="LayersMenuItemActive" id="LayerMenu_contracts" href="#" onclick="toggle_layer('contracts')">Nuværende status</a><br/>
</td>
</tr>
</table>
@@ -367,12 +367,12 @@
</div>
</div>
<div id="qmLaden" style="position:absolute; width:158px; height:16px; z-index:21; left: 560px; top: 165px; visibility: hidden;" class="Laden">
- <div align="center" valign="middle">Please wait, loading ...</div>
+ <div align="center" valign="middle">Vent venligst, loading ...</div>
</div>
<div id="qmAusschnittRahmen" style="position:absolute; width:178; height:131px; z-index:3; top: 99px; left: 550px; visibility: inherit;" class="KarteRahmen">
<table width="178" border="0" cellspacing="0" cellpadding="0">
<tr>
- <td class="InfoKopf" >click on "sold" m²s!</td>
+ <td class="InfoKopf" >Klik på "solgt" m²!</td>
</tr>
<tr>
<td align="center" valign="middle">
@@ -384,7 +384,7 @@
<div id="qmInfo" style="position:absolute; width:178px; height:218px; z-index:10; top: 242px; left: 550px; visibility: inherit;" class="KarteRahmen">
<table width="178" border="0" cellspacing="0" cellpadding="0">
<tr>
- <td class="InfoKopf">Sponsor Information</td>
+ <td class="InfoKopf">Sponsor information</td>
</tr>
<tr>
<td width="160" align="left" valign="top">
@@ -397,7 +397,7 @@
</div>
<div id="qmhome" style="position:absolute; width:140px; height:20px; z-index:6; left: 10px; top: 105px; visibility: inherit;" class="NavigationAktiv">
<img src="/images/pfeil_link_on.gif" width="29" height="12" border="0"/>
- "sold" m²
+ "solgt" m²
</div>
<div id="qmAusschnitt" style="position:absolute; width:200px; height:115px; z-index:7; left: 172px; top: 512px; visibility: inherit;">
<div id="lupe_selected_contract" style="position:absolute; z-index:10; visibility: inherit;">
@@ -435,20 +435,20 @@
</table>
</div>
</div>
- <div id="Ueberschrift" style="position:absolute; width:290px; height:20px; z-index:5; left: 169px; top: 80px;">Samboja Lestari - Overview</div>
- <div id="Untertitel" style="position:absolute; width:350px; height:20px; z-index:5; left: 169px; top: 469px;" align="right">More than 17 million square metres for eternity.</div>
+ <div id="Ueberschrift" style="position:absolute; width:290px; height:20px; z-index:5; left: 169px; top: 80px;">Samboja Lestari - Overblik</div>
+ <div id="Untertitel" style="position:absolute; width:350px; height:20px; z-index:5; left: 169px; top: 469px;" align="right">Mere end 17 millioner kvadratmeter i al evighed.</div>
<div class="Links" style="position:absolute; width:178px; height:132px; z-index:3; top: 482px; left: 550px;">
<span style="padding-right:2px">
<img src="/images/pfeil_link_on.gif" border="0" />
- <a class="FaehnchenLink" href="javascript:window_infosystem_hilfe();"> Help </a>
+ <a class="FaehnchenLink" href="javascript:window_infosystem_hilfe();"> Hjælp </a>
</span>
<span style="padding-right:2px">
<img src="/images/pfeil_link_on.gif" border="0" />
- <a class="FaehnchenLink" href="javascript:bestellung();"> Buy m²s </a>
+ <a class="FaehnchenLink" href="javascript:bestellung();"> Køb m²s </a>
</span>
<span style="padding-right:2px">
<img src="/images/pfeil_link_on.gif" border="0" />
- <a class="FaehnchenLink" href="javascript:window.close();"> Close </a>
+ <a class="FaehnchenLink" href="javascript:window.close();"> Luk </a>
</span>
</div>
<div id="dataqm" style="position:absolute; width:1px; height:1px; z-index:11; left: 1px; top: 1px;"></div>
1
0