Author: hhubner Date: 2007-10-04 13:23:45 -0400 (Thu, 04 Oct 2007) New Revision: 2200
Added: branches/trunk-reorg/thirdparty/slime/ branches/trunk-reorg/thirdparty/slime/.cvsignore branches/trunk-reorg/thirdparty/slime/CVS/ branches/trunk-reorg/thirdparty/slime/CVS/Entries branches/trunk-reorg/thirdparty/slime/CVS/Entries.Log branches/trunk-reorg/thirdparty/slime/CVS/Repository branches/trunk-reorg/thirdparty/slime/CVS/Root branches/trunk-reorg/thirdparty/slime/CVS/Template branches/trunk-reorg/thirdparty/slime/ChangeLog branches/trunk-reorg/thirdparty/slime/HACKING branches/trunk-reorg/thirdparty/slime/NEWS branches/trunk-reorg/thirdparty/slime/PROBLEMS branches/trunk-reorg/thirdparty/slime/README branches/trunk-reorg/thirdparty/slime/contrib/ branches/trunk-reorg/thirdparty/slime/contrib/CVS/ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries branches/trunk-reorg/thirdparty/slime/contrib/CVS/Repository branches/trunk-reorg/thirdparty/slime/contrib/CVS/Root branches/trunk-reorg/thirdparty/slime/contrib/CVS/Template branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog branches/trunk-reorg/thirdparty/slime/contrib/README branches/trunk-reorg/thirdparty/slime/contrib/bridge.el branches/trunk-reorg/thirdparty/slime/contrib/inferior-slime.el branches/trunk-reorg/thirdparty/slime/contrib/slime-asdf.el branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el branches/trunk-reorg/thirdparty/slime/contrib/slime-banner.el branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el branches/trunk-reorg/thirdparty/slime/contrib/slime-highlight-edits.el branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el branches/trunk-reorg/thirdparty/slime/contrib/slime-presentation-streams.el branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el branches/trunk-reorg/thirdparty/slime/contrib/slime-references.el branches/trunk-reorg/thirdparty/slime/contrib/slime-scratch.el branches/trunk-reorg/thirdparty/slime/contrib/slime-tramp.el branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-asdf.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-c-p-c.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-listener-hooks.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-presentations.lisp branches/trunk-reorg/thirdparty/slime/doc/ branches/trunk-reorg/thirdparty/slime/doc/.cvsignore branches/trunk-reorg/thirdparty/slime/doc/CVS/ branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries branches/trunk-reorg/thirdparty/slime/doc/CVS/Repository branches/trunk-reorg/thirdparty/slime/doc/CVS/Root branches/trunk-reorg/thirdparty/slime/doc/CVS/Template branches/trunk-reorg/thirdparty/slime/doc/Makefile branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.pdf branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.tex branches/trunk-reorg/thirdparty/slime/doc/slime-small.eps branches/trunk-reorg/thirdparty/slime/doc/slime-small.pdf branches/trunk-reorg/thirdparty/slime/doc/slime.texi branches/trunk-reorg/thirdparty/slime/doc/texinfo-tabulate.awk branches/trunk-reorg/thirdparty/slime/hyperspec.el branches/trunk-reorg/thirdparty/slime/metering.lisp branches/trunk-reorg/thirdparty/slime/mkdist.sh branches/trunk-reorg/thirdparty/slime/nregex.lisp branches/trunk-reorg/thirdparty/slime/sbcl-pprint-patch.lisp branches/trunk-reorg/thirdparty/slime/slime-autoloads.el branches/trunk-reorg/thirdparty/slime/slime.el branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp branches/trunk-reorg/thirdparty/slime/swank-backend.lisp branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp branches/trunk-reorg/thirdparty/slime/swank-corman.lisp branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp branches/trunk-reorg/thirdparty/slime/swank-gray.lisp branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp branches/trunk-reorg/thirdparty/slime/swank-loader.lisp branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp branches/trunk-reorg/thirdparty/slime/swank-scl.lisp branches/trunk-reorg/thirdparty/slime/swank-source-file-cache.lisp branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp branches/trunk-reorg/thirdparty/slime/swank.asd branches/trunk-reorg/thirdparty/slime/swank.lisp branches/trunk-reorg/thirdparty/slime/test-all.sh branches/trunk-reorg/thirdparty/slime/test.sh branches/trunk-reorg/thirdparty/slime/xref.lisp Log: update slime
Added: branches/trunk-reorg/thirdparty/slime/.cvsignore =================================================================== --- branches/trunk-reorg/thirdparty/slime/.cvsignore 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/.cvsignore 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,6 @@ +*.x86f +*.fasl +*.dfsl +*.lx64fsl +*.elc +_darcs
Added: branches/trunk-reorg/thirdparty/slime/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/slime/CVS/Entries 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/CVS/Entries 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,34 @@ +/.cvsignore/1.5/Sun Apr 8 19:23:57 2007// +/ChangeLog/1.1234/Thu Sep 27 12:56:13 2007// +/HACKING/1.8/Wed Sep 19 11:08:27 2007// +/NEWS/1.8/Sun Mar 27 19:41:17 2005// +/PROBLEMS/1.8/Sun Nov 20 23:31:56 2005// +/README/1.14/Tue Oct 3 21:49:13 2006// +/hyperspec.el/1.11/Thu Dec 7 07:36:54 2006// +/metering.lisp/1.4/Fri Apr 1 20:16:35 2005// +/mkdist.sh/1.7/Mon Aug 29 20:02:58 2005// +/nregex.lisp/1.4/Mon Sep 19 08:20:48 2005// +/sbcl-pprint-patch.lisp/1.1/Fri Feb 17 01:30:21 2006// +/slime-autoloads.el/1.3/Thu Sep 20 14:59:08 2007// +/slime.el/1.875/Thu Sep 27 12:56:40 2007// +/swank-abcl.lisp/1.43/Tue Sep 4 15:45:19 2007// +/swank-allegro.lisp/1.98/Wed Sep 26 23:15:41 2007// +/swank-backend.lisp/1.126/Mon Sep 10 15:39:05 2007// +/swank-clisp.lisp/1.64/Thu Aug 23 19:03:37 2007// +/swank-cmucl.lisp/1.174/Wed Sep 5 12:04:43 2007// +/swank-corman.lisp/1.11/Thu Aug 23 19:03:37 2007// +/swank-ecl.lisp/1.8/Thu May 17 11:49:40 2007// +/swank-gray.lisp/1.10/Wed Apr 12 08:43:55 2006// +/swank-lispworks.lisp/1.92/Thu Aug 23 19:03:37 2007// +/swank-loader.lisp/1.73/Fri Sep 14 12:41:28 2007// +/swank-openmcl.lisp/1.119/Thu Aug 23 19:03:37 2007// +/swank-sbcl.lisp/1.185/Tue Sep 11 19:31:03 2007// +/swank-scl.lisp/1.13/Thu Aug 23 19:03:37 2007// +/swank-source-file-cache.lisp/1.8/Tue Dec 5 13:00:42 2006// +/swank-source-path-parser.lisp/1.17/Sun Jun 25 08:33:16 2006// +/swank.asd/1.5/Fri Sep 14 12:41:28 2007// +/swank.lisp/1.511/Wed Sep 19 11:12:07 2007// +/test-all.sh/1.2/Mon Aug 29 20:02:58 2005// +/test.sh/1.9/Mon Aug 27 13:16:49 2007// +/xref.lisp/1.2/Mon May 17 00:25:24 2004// +D
Added: branches/trunk-reorg/thirdparty/slime/CVS/Entries.Log =================================================================== --- branches/trunk-reorg/thirdparty/slime/CVS/Entries.Log 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/CVS/Entries.Log 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,2 @@ +A D/contrib//// +A D/doc////
Added: branches/trunk-reorg/thirdparty/slime/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/slime/CVS/Repository 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/CVS/Repository 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +slime
Added: branches/trunk-reorg/thirdparty/slime/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/slime/CVS/Root 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/CVS/Root 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +:pserver:anonymous:anonymous@common-lisp.net:/project/slime/cvsroot
Added: branches/trunk-reorg/thirdparty/slime/CVS/Template ===================================================================
Added: branches/trunk-reorg/thirdparty/slime/ChangeLog =================================================================== --- branches/trunk-reorg/thirdparty/slime/ChangeLog 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/ChangeLog 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,13172 @@ +2007-09-27 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-filesystem-toplevel-directory): New function. + Windows doesn't have a filesystem that is as hierarchical as the + Unix' one. Reported by Carsten Blaauw and Stefan Kluehspies. + (slime-file-name-merge-source-root): Use it. + (slime-highlight-differences-in-dirname): Use it. + +2007-09-26 Utz-Uwe Haus haus+slime@mail.math.uni-magdeburg.de + + * swank-allegro.lisp (fspec-definition-locations): Allow the + POSITION datum of :top-level-form fspecs to be missing. This + apparently helpful for Allegro CL 8.1. + +2007-09-21 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-length=, slime-length>): Restore support for + vectors, as `slime-length=' was already used with strings in + `slime-parse.el'. This broke extended arglist display. + +2007-09-20 Helmut Eller heller@common-lisp.net + + * slime.el (slime-setup): Call the respective init functions of + contribs. + + * slime-autoloads.el (slime-setup-contribs): Ditto. + +2007-09-19 Helmut Eller heller@common-lisp.net + + Simplify slime-compile-file. + + * slime.el (slime-compile-file): Don't save window config. + (slime-curry, slime-rcurry): New functions. + + * slime.el (slime-complete-symbol*-fancy): Move defcustom to + contrib/slime-c-p-c.el + + * swank-version.el: Delete file. No longer used. + + * bridge.el: Moved to contrib. + + * tree-widget.el: File deleted. Only needed by contribs and is + distributed with Emacs 21. + + * slime.el: Reorder some devfars and menus code so that the + compiler doesn't complain about free variables. + + Fix apropos in Emacs 22. + + * slime.el (slime-print-apropos): Add button props for Emacs 22. + (slime-call-describer): ARG is a marker in Emacs 22. + + (def-slime-selector-method ?c): Wait until slime-list-threads + returns. + + Remove define-slime-dialect. + + * slime.el (define-slime-dialect): Deleted. Use + slime-lisp-implementations instead. + + Introduce a slime-start-and-init function. + + * slime.el (slime-start-and-init, slime-lisp-options): New + functions. + (slime-start-and-load): Use it. + + Simplify slime-length=. + + * slime.el (slime-length=, slime-length>): No need for vectors. + + Remove explicit support for Scheme mode. + + * slime.el (slime-scheme-mode-hook, slime-shared-lisp-mode-hook) + Deleted. + (slime-indentation-update-hooks): New hook. + (slime-handle-indentation-update): Use it. + + Fix close-connection. + + * swank.lisp (close-connection): Use *log-output* instead of + *debug-io* (which could be redirected to the to-be-closed + connection). + +2007-09-15 Helmut Eller heller@common-lisp.net + + Let slime-setup load contribs. + + * slime.el (slime-setup): Take a list of contribs to load as + argument. + + * slime-autoloads.el (slime-setup): Ditto, but delay the actual + loading until slime is loaded. + (slime-setup-contribs): New function. + +2007-09-15 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-maybe-warn-for-different-source-root): Catch + returned NIL from `slime-file-name-merge-source-root' if the two + filenames don't share a common source root. + Reported by Frank Goenninger. + +2007-09-15 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-split-string): New semi-portability function. + The behaviour of `split-string' changed between Emacs21 and + Emacs22. Thanks to Christophe Rhodes for reporting this. + (slime-file-name-merge-source-root): Use `slime-split-string'. + (slime-highlight-differences-in-dirname): Likewise. + +2007-09-14 Helmut Eller heller@common-lisp.net + + Some cleanups for the REPL. + + * slime.el (slime-repl-write-string): Split it up into smaller + functions. + (slime-repl-emit, slime-repl-emit-result) + (slime-emit-string): New functions. + + (slime-repl-save-history): Use prin1 instead of pp. + + (repl-type-ahead): New test case. + +2007-09-12 Christophe Rhodes csr21@cantab.net + + Make ASDF:LOAD-OP (and SBCL REQUIRE) happy with swank.asd + + * swank.asd: Define and use a CL-SCRIPT-FILE class for loading as + source, even with ASDF:LOAD-OP. + +2007-09-11 Tobias C. Rittweiler tcr@freebits.de + + * swank-loader.lisp: Aways compile-file `contrib/swank-asdf.lisp' + on SBCL. This fixes "Undefined function" style-warnings when using + `slime-asdf' in combination with SBCL. Reported by Cyrus Harmon. + + * swank-sbcl.lisp: Explicitly require ASDF. (While this is not + strictly necessary, as it's implicitly loaded on requiring the + other modules, I think it's better to be explicit about it.) + +2007-09-10 Helmut Eller heller@common-lisp.net + + Fix some bugs introduced while moving doc refs to contrib. + + * swank-sbcl.lisp (condition-references): It's still needed. + + * slime.el (sldb-dispatch-extras): Add missing quote. + (slime-sbcl-manual-root): Move definition to + contrib/slime-references.el. + (slime-cl-symbol-name, slime-cl-symbol-package): Move to + contrib/slime-parse.el. + +2007-09-10 Helmut Eller heller@common-lisp.net + + Move SBCL doc references to contrib. + + * slime.el (sldb-insert-condition): Merge REFERENCES and EXTRAS. + (sldb-extras-hooks, sldb-dispatch-extras): New hook. + + * swank-backend.lisp (condition-references): Removed. Merged with + condition-extras. + + * swank-sbcl.lisp (condition-references): Removed. + (condition-extras): Include references. + (externalize-reference): New function. Don't return plain + symbols. + + * swank-allegro.lisp (condition-references): Removed. + +2007-09-10 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-cl-symbol-name, slime-cl-symbol-package): + Ressurected, as they're still used in this file. + Reported by Edward Cant. + +2007-09-10 Tobias C. Rittweiler tcr@freebits.de + + When working on multiple source trees simultaneously, the way + `slime-edit-definition' (M-.) works can sometimes be confusing: + + `M-.' visits locations that are present in the current Lisp image, + which works perfectly well as long as the image reflects the + source tree that one is currently looking at. + + In the other case, however, one can easily end up visiting a file + in a different source root directory (the one corresponding to the + Lisp image), and is thus easily tricked to modify the wrong source + files---which can lead to quite some stressfull cursing. + + If the variable `slime-warn-when-possibly-tricked-by-M-.' is + T (the default), a warning message is issued to raise the user's + attention whenever `M-.' is about opening a file in a different + source root that also exists in the source root directory of the + user's _current buffer_. + + There's no guarantee that all possible cases are covered, but if + you encounter such a warning, it's a strong indication that you + should check twice before modifying. + + * slime.el (slime-file-name-merge-source-root): New function. + (slime-highlight-differences-in-dirname): New function. + (slime-maybe-warn-for-different-source-root): New function. + (slime-warn-when-possibly-tricked-by-M-.): New variable (T by default.) + (slime-goto-location-buffer): Where appropriate, call + `slime-maybe-warn-for-different-source-root' + +2007-09-08 Stelian Ionescu sionescu@common-lisp.net + + * slime.el (save-restriction-if-possible): Place macro definition + above use of the macro, to regain ability to byte-compile-file. + +2007-09-08 Tobias C. Rittweiler tcr@freebits.de + + Fix message displaying on XEmacs. Reported by Steven E. Harris, + and Ken Causey. + + * slime.el (slime-display-message): Resurrect secondary + `buffer-name' argument which got lost in 2007-08-24. + (slime-format-display-message): Resurrect passing "*SLIME Note*" + as default buffer-name to `slime-display-message'. + +2007-09-08 Matt Pillsbury mtbp@rci.rutgers.edu + + * swank-backend.lisp (definterface): Updated docstring. + +2007-09-06 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime.el (slime-repl-write-string): Use case, not ecase, for + dispatching targets.Should fix XEmacs compatibility. + Reported by Steven E. Harris. + +2007-09-05 Didier Verna didier@xemacs.org + + * slime.el (slime-filename-translations): Fix custom type. + +2007-09-05 Helmut Eller heller@common-lisp.net + + * slime.el (slime-toggle-trace-fdefinition): Fix typo. The + argument for interactive should be "P" not "p". + +2007-09-04 Mark Evenson mark.evenson@gmx.at + + * swank-abcl.lisp: Call accessors of compiler-condition at load + time to work around some ABCL problems. + +2007-09-04 Helmut Eller heller@common-lisp.net + + Move asdf support to contrib. + + * swank-backend.lisp (operate-on-system): Moved to + swank-asdf.lisp. It wasn't specialized in any backend. + + * swank.lisp (operate-on-system-for-emacs) + (list-all-systems-known-to-asdf, list-asdf-systems): Moved to + swank-asdf.lisp. + + * slime.el: Move asdf commands to contrib slime-adsf.el. + + * swank-loader.lisp: Load swank-asdf if ASDF is in + *FEATURES*. Also add the contrib source directory to + swank::*load-path*. + +2007-09-04 Helmut Eller heller@common-lisp.net + + * slime.el: Move tramp support to contrib. + +2007-09-04 Helmut Eller heller@common-lisp.net + + Move startup animation to contrib. + + * slime.el (slime-repl-banner-function): New hook. + (slime-repl-update-banner): Use it and reset markers after calling + it. + (slime-set-default-directory): Don't call slime-repl-update-banner + here. + (slime-repl-insert-prompt): Set slime-repl-input-end-mark to + point-max. + +2007-09-04 Helmut Eller heller@common-lisp.net + + * slime.el: Move inferior-slime-mode to contrib. + +2007-09-04 Helmut Eller heller@common-lisp.net + + * slime.el: Fix the test suite (except for SBCL). + +2007-09-04 Helmut Eller heller@common-lisp.net + + Simplify slime-process-available-input. + + * slime.el (slime-process-available-input): We are called in a + process filter, i.e. at arbitrary times and in an aribtrary + buffer. So it doesn't make sense to save-and-restore the current + buffer here + (slime-eval-async): Instead, save and restore the buffer here. + (slime-net-read-or-lose): New. + +2007-09-04 Helmut Eller heller@common-lisp.net + + Remove request-abort condition. + + * swank-backend.lisp (request-abort): Removed + (abort-request): Removed. Replace all (3) uses with ERROR. + * swank.lisp (eval-for-emacs): No special case for request-abort. + * slime.el (slime-eval-async): Remove optional arg of :abort. + +2007-09-04 Helmut Eller heller@common-lisp.net + + Rename slime-insert-possibly-as-rectangle to slime-insert-indented. + + * slime.el (slime-insert-indented): Renamed. Update callers. + +2007-08-31 Helmut Eller heller@common-lisp.net + + Move compound prefix completion and autodoc to contrib. + + * swank.lisp (simple-completions): Rewritten for simplicity. + (operator-arglist): Rewritten for simplicity. + + * slime.el (slime-complete-symbol-function): Make simple + completion the default. + (slime-echo-arglist-function, slime-echo-arglist): New hook. + + Remove corresponding key bindigs. + + * slime.el (slime-obsolete-commands): New table. Use it to bind + a command with an upgrade notice. + +2007-08-31 Andreas Fuchs asf@boinkor.net + + * slime.el (slime-reindent-defun): Fixed when used in lisp file + buffers. (Similiar patch also provided by G�bor Melis; problem + also reported by Jeff Cunningham.) + +2007-08-31 Jon Allen Boone ipmonger@delamancha.org + + * swank-cmucl.lisp: CMUCL now has an x86-Darwin port as well as + the PPC-Darwin version. Changed to conditionalize on the + presence of darwin instead of ppc so that slime works with both + Darwin versions of CMUCL. + +2007-08-31 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-sexp-at-point): Explicitely set current syntax + table to operate in `lisp-mode-syntax-table' because + `thing-at-point' is used which depends on the syntax table. (E.g. + keywords like `:foo' aren't recognized as sexp otherwise.) + + * slime.el (slime-parse-extended-operator/declare): Wrap regexp + stuff in `save-match-data' + (slime-internal-scratch-buffer): Removed again. Was only + introduced as a performance hack; but it turned out that the bad + performance was because of unneccessary recursive calls of + `slime-make-form-spec-from-string'. (Which was fixed on 2007-08-27 + already.) + (slime-make-form-spec-from-string): Use `with-temp-buffer' instead + of `slime-internal-scratch-buffer'. Removed activation of + `lisp-mode' in the temporary buffer, because this made + `lisp-mode-hooks' run. This activated autodoc in the temp buffer, + although the temp buffer is used to compute an autodoc + itself (which resulted in some very mutual recursion which caused + the current arglist to be displayed again and again---as could + have been witnessed in `*Messages*'.) `Lisp-mode' was activated to + get the right syntax-table for `slime-sexp-at-point', but this one + sets the correct syntax-table itself now. + +2007-08-28 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Fix user input type-ahead again (this change from 2007-08-25 got + lost). Testcase: Type (dotimes (i 5) (format t "Number ~A~%" + i) (sleep 1)) and then type ahead while the command is executing + and output arrives. + + * slime.el (slime-repl-insert-prompt): Don't go to point-max but + to slime-repl-input-start-mark if there is one. + (slime-repl-write-string): Insert a :repl-result before the + prompt, not at point-max. Update markers properly. + +2007-08-28 Helmut Eller heller@common-lisp.net + + * swank-cmucl.lisp (safe-definition-finding): Remove whitespace + around error messages. + (trim-whitespace): New function. + +2007-08-28 Helmut Eller heller@common-lisp.net + + Fix some output related bugs. + + * swank.lisp (send-repl-results-to-emacs): Emit a fresh line. + + * slime.el (slime-insert-transcript-delimiter): Use + insert-before-markers since slime-output-end is no longer left + inserting. Reported by Austin Haas austin@pettomato.com. + +2007-08-28 Helmut Eller heller@common-lisp.net + + * slime.el (slime-display-or-scroll-completions, + slime-scroll-completions): New functions. Factored out of + slime-expand-abbreviations-and-complete. + +2007-08-28 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime.el (slime-repl-write-string): Handle arbitrary targets + using slime-output-target-marker. + (slime-last-output-target-id, slime-output-target-to-marker) + (slime-output-target-marker) + (slime-redirect-trace-output): Move back here from slime-presentations.el. + +2007-08-28 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp (classify-symbol, symbol-classification->string): + Resurrected in swank.lisp. (I was bitten by cvs-pcl which + committed (2007-08-27) my locally changed `contribs/swank-fuzzy.lisp' + where I already removed these functions from.) + +2007-08-28 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-make-form-spec-from-string): Elisp Hacking 101: + Don't use `beginning-of-buffer' and `end-of-buffer' in Elisp code. + + * swank.lisp (read-form-spec): Unintern just newly interned + symbols when an reader error occurs. + +2007-08-28 Helmut Eller heller@common-lisp.net + + Move presentations to contrib. Part II. + + * swank.lisp (*listener-eval-function*): New variables. + (listener-eval): Use it + (repl-eval): Used to be listener-eval. + (*send-repl-results-function*): New variable. + (eval-region): Simplify. + (track-package, cat): New functions. + (slime-repl-clear-buffer-hook): New hook. + (slime-repl-clear-buffer): Use it. + +2007-08-28 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Remove the ID argument from :write-string protocol messages. + Everything, except for rigid-indentation tricks, can be achieved + by using :write-string in conjunction with :presentation-start and + :presentation-end. + + * swank.lisp (present-in-emacs): Unused, removed. + + * swank.lisp (make-output-function-for-target): Remove id argument + from :write-string. + (send-repl-results-to-emacs): Don't call + save-presented-object. Remove id argument from :write-string. + + * slime.el (slime-dispatch-event): Change it here. + (slime-write-string, slime-repl-write-string): And here. + +2007-08-28 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * swank-loader.lisp (*contribs*): Add swank-presentations. + +2007-08-27 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-make-extended-operator-parser/look-ahead): Move + to end of symbol at point. + (slime-make-form-spec-from-string): Fixes unexpected behaviour of + `save-excursion'. + +2007-08-27 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-sexp-at-point): Fixes a few edge cases were + Emacs' `(thing-at-point 'sexp)' behaves suboptimally. For example, + `foo(bar baz)' where point is at the ?(. + (slime-internal-scratch-buffer): New. This variable holds an + internal scratch buffer that can be reused instead of having to + create a new temporary buffer again and again. + (slime-make-extended-operator-parser/look-ahead): Uses + `slime-make-form-spec-from-string' to parse nested expressions + properly. + (slime-nesting-until-point): Added docstring. + (slime-make-form-spec-from-string): Added new optional parameter + for stripping the operator off the passed string representation of + a form. Necessary to work in the context of + `slime-make-extended-operator-parser/look-ahead'. Added safety check + against a possible endless recursion. + + * swank.lisp (parse-form-spec): Looses restriction for nesting. + +2007-08-27 Helmut Eller heller@common-lisp.net + + * slime.el (slime-eval-feature-conditional): Fix typo. + (slime-keywordify): Simplify. + +2007-08-27 Helmut Eller heller@common-lisp.net + + Move presentations to contrib. Part I. + + * slime.el (slime-event-hooks, slime-dispatch-event): New hook. + (slime-write-string-function, slime-write-string): New hook. + (slime-repl-return-hooks, slime-repl-return): New hook. + (slime-repl-current-input-hooks, slime-repl-current-input): New hook. + (slime-open-stream-hooks, slime-open-stream-to-lisp): New hook. + (sldb-insert-locals, slime-inspector-insert-ispec) + (slime-last-expression): Don't use presentations. + +2007-08-26 Tobias C. Rittweiler tcr@freebits.de + + Reduces needless interning of symbols that was introduced by my + recent work on autodoc to a minimum. Also fixes this issue for + `slime-complete-form' which always interned symbols even before my + changes. + + * slime.el (slime-sexp-at-point): If N is given, but there aren't + N sexps available at point, make it return a list of just as many + as there are. + (slime-make-form-spec-from-string): New. Creates a ``raw form + spec'' from a string that's suited for determining newly interned + symbols later in Swank. + (slime-parse-extended-operator/declare): Uses it. + + * swank.lisp (parse-symbol): Returns internal knowledge, to + provide a means for callers to perform a sanity check. + (call-with-ignored-reader-errors): New. Abstracted out from + `read-incomplete-form-from-string.' + + * swank.lisp (read-form-spec): New. Only READs elements of a form + spec if necessary. And if it does have to READ, it keeps track + of newly interned symbols which are returned as secondary + return value. + (parse-form-spec): Use it. Propagate newly interned symbols. + (parse-first-valid-form-spec): Likewise. + (arglist-for-echo-area, complete-form, completions-for-keyword): + Adapted to unintern the newly interned symbols. + + +2007-08-26 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (current-slime-narrowing-configuration): + Renamed to `slime-current-narrowing-configuration'. + (set-slime-narrowing-configuration): + Renamed to `slime-set-narrowing-configuration'. + (current-slime-emacs-snapshot): + Renamed to `slime-current-emacs-snapshot'. + (current-slime-emacs-snapshot-fingerprint): + Renamed to `slime-current-emacs-snapshot-fingerprint'. + (set-slime-emacs-snapshot): + Renamed to `slime-set-emacs-snapshot'. + +2007-08-26 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (save-restriction-if-possible): Fixed another typo, + duh! Thanks again to Matthias Koeppe. + +2007-08-26 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-cl-symbol-name): Handle vertical bars (|) + (%slime-nesting-until-point): Renamed to `slime-nesting-until-point'. + +2007-08-25 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Fix a bug where REPL results would sometimes be indented by a + random amount. + + * slime.el (slime-insert-presentation): Make the + rectangle-ification of multi-line presentations, introduced + 2006-12-19, optional. + (slime-write-string): Use it here only for regular output, but not + for REPL results. + (sldb-insert-locals): Use it here. + (slime-inspector-insert-ispec): Use it here. + +2007-08-25 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Fix handling of user-input type-ahead in the REPL. + Reported by Madhu enometh@meer.net on 2007-04-24. + + * slime.el (slime-write-string): Make sure text properties are + rear-nonsticky, so typed-ahead user input does not pick up the + text properties. Fix up some markers. + (slime-reset-repl-markers): Make the marker slime-output-end of + insertion type nil (no automatic advances on insertions). + (slime-with-output-end-mark): Update the location of + slime-output-end here manually. + (slime-repl-update-banner): Use insert-before-markers. + +2007-08-25 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + New command slime-redirect-trace-output creates a separate Emacs + buffer, where all subsequent trace output is sent. + + * slime.el (slime-last-output-target-id): New variable. + (slime-output-target-to-marker): New variable. + (slime-output-target-marker): New function. + (slime-write-string): Handle general "target" arguments using + slime-output-target-marker. + (slime-redirect-trace-output): New command. + (slime-easy-menu): Add a menu item for it. + + * slime.el (slime-mark-presentation-start) + (slime-mark-presentation-end): Make "target" argument optional. + Use slime-output-target-to-marker. + + * swank.lisp (make-output-stream-for-target): New function, + factored out from open-streams. + (open-streams): Use it here. + + * swank.lisp (connection): New slot "trace-output". + (call-with-redirected-io): Use it here. + (redirect-trace-output): New slimefun; set the slot to a new + target stream. + +2007-08-25 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (save-restriction-if-possible): Fixed typo in + macroexpansion. Thanks to Matthias Koeppe for reporting. + +2007-08-24 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime.el (slime-insert-arglist): Removed, superseded by + slime-complete-form since 2005-02-20. + + * swank.lisp (arglist-for-insertion): Now unused, removed. + +2007-08-24 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Some fixes to the presentation-streams contrib. + + * slime.el (slime-dispatch-event): Handle new optionals args of + messages :presentation-start and :presentation-end. + + * slime.el (slime-mark-presentation-start) + (slime-mark-presentation-end): New arg "target"; record + presentation boundaries separately for REPL results and regular + process output. This fixes the presentation markup of REPL + results when the presentation-streams contrib is loaded. + +2007-08-24 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Make the fancy presentation-streams feature a contrib. + Previously, it was only available if "present.lisp" was loaded + manually. Now it can be loaded automatically using: + + (add-hook 'slime-load-hook + (lambda () (require 'slime-presentation-streams))) + + Note that the normal presentations that are created by REPL + results, the inspector, and the debugger are NOT dependent on this + code. + + * present.lisp: Moved to contrib/swank-presentation-streams.lisp. + * swank-loader.lisp (*contribs*): Add swank-presentation-streams. + +2007-08-24 Helmut Eller heller@common-lisp.net + + Move typeout frame to contrib. + + * slime.el (slime-message-function, slime-background-message-function) + (slime-autodoc-message-function): New variables. + (slime-message, slime-background-message) + (slime-autodoc-message): Call the function in the respective + variable, so that the typeout window can be plugged in. + +2007-08-24 Helmut Eller heller@common-lisp.net + + Move xref and class browser to contrib. + + * slime.el (slime-browse-classes, slime-browse-xrefs): Gone. The + Common Lisp part is still there. + +2007-08-24 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-forward-blanks): Wrapped w/ `ignore-errors.' + (slime-sexp-at-point): Return results as a list of strings, rather + than just one big string if called with arg > 1. + (slime-parse-extended-operator-name): Wrapping some movement code + in `ignore-errors'. Adapted to new return value of + `slime-enclosing-form-specs'. Minor cosmetic changes. + (slime-make-extended-operator-parser/look-ahead): Adapted to + changes of the ``raw form spec'' format; returns a form of + strings, instead of a string of a form. + (slime-parse-extended-operator/declare): Simplified. Adapted to + changes of the ``raw form spec'' format; passes decl-identifiers, + or typespec-operators respectively, along the decl/type-spec. + (%slime-in-mid-of-typespec-p): Removed. Replaced by an regexp + based approach. + (%slime-nesting-until-point): New helper for + `slime-parse-extended-operator/declare'. + + * swank.lisp (parse-form-spec): Adapted to new ``raw form spec'' + format. Updated format description in docstring accordingly. The + new format allows less interning of wrong symbols names comming + from Slime. Thanks to Matthias Koeppe for spotting this. + +2007-08-24 Helmut Eller heller@common-lisp.net + + Move slime-highlight-edits-mode to contrib. + +2007-08-24 Helmut Eller heller@common-lisp.net + + Move slime-scratch to contrib. + + * slime.el (slime-scratch): Gone. + +2007-08-24 Helmut Eller heller@common-lisp.net + + Various cleanups related to slime-insert-propertized. + + * slime.el (slime-with-rigid-indentation): Fix evaluation order. + (slime-indent-rigidly): New. + (slime-insert-possibly-as-rectange): Don't set mark. + (slime-insert-propertized): Use plain insert instead of + slime-insert-possibly-as-rectange. + +2007-08-24 Helmut Eller heller@common-lisp.net + + * swank-sbcl.lisp (sbcl-inspector): Fix typo. + +2007-08-23 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Repair inspection of presentations. + + * swank.lisp (inspect-presentation): New slimefun. + * slime.el (slime-inspect-presentation-at-mouse): Use it here. + +2007-08-23 Helmut Eller heller@common-lisp.net + + Move Marco Baringer's inspector to contrib. + + * swank.lisp (*default-inspector*): New variable. Set this + variable dispatch to different inspectors. + (inspect-object): Use it. + + * swank-loader.lisp (*contribs*): Add 'swank-fancy-inspector. + + * swank-backend.lisp (backend-inspector): New class. Introduce a + named class to give as another way to dispatch to backend methods. + + * swank-cmucl.lisp: Use backend-inspector class. + * swank-sbcl.lisp: Use backend-inspector class. + * swank-clisp.lisp: Use backend-inspector class. + * swank-lispworks.lisp: Use backend-inspector class. + * swank-allegro.lisp: Use backend-inspector class. + * swank-openmcl.lisp: Use backend-inspector class. + * swank-abcl.lisp: Use backend-inspector class. + * swank-corman.lisp: Use backend-inspector class. + * swank-scl.lisp: Use backend-inspector class. + +2007-08-23 Tobias C. Rittweiler tcr@freebits.de + + Added arglist display for declaration specifiers and type + specifiers. + + Examples: + + `(declare (type' will display + + (declare (type type-specifier &rest vars)) + + `(declare (type (float' will display + + [Typespec] (float &optional lower-limit upper-limit) + + `(declare (optimize' will display + + (declare (optimize &any (safety 1) (space 1) (speed 1) ...)) + + &ANY is a new lambda keyword that is introduced for arglist + description purpose, and is very similiar to &KEY, but isn't based + upon plists; they're more based upon *FEATURES* lists. (See the + comment near the ARGLIST defstruct in `swank.lisp'.) + + * slime.el: + (slime-to-feature-keyword): Renamed to `slime-keywordify'. + (slime-eval-feature-conditional): Adapted to use `slime-keywordify'. + (slime-ensure-list): New utility. + (slime-sexp-at-point): Now takes an argument that specify how many + sexps at point should be returned. + (slime-enclosing-operator-names): Renamed to + `slime-enclosing-form-specs'. + (slime-enclosing-form-specs): Returns a list of ``raw form specs'' + instead of what was called ``extended operator names'' before, see + `swank::parse-form-spec' for more information. This is a + simplified superset. Additionally as tertiary return value return + a list of points to let the caller see where each form spec is + located. Adapted callers accordingly. Extended docstring. + (slime-parse-extended-operator-name): Adapted to changes in + `slime-enclosing-form-specs'. Now gets more context, and is such + more powerful. This was needed to allow parsing DECLARE forms. + (slime-make-extended-operator-parser/look-ahead): Because the + protocol for arglist display was simplified, it was possible to + replace the plethora of parsing function just by this one. + (slime-extended-operator-name-parser-alist): Use it. Also add + parser for DECLARE forms. + (slime-parse-extended-operator/declare): Responsible for parsing + DECLARE forms. + (%slime-in-mid-of-typespec-p): Helper function for + `slime-parse-extended-operator/declare'. + (slime-incomplete-form-at-point): New. Return the ``raw form + spec'' near point. + (slime-complete-form): Use `slime-incomplete-form-at-point'. + + * swank.lisp: New Helper functions. + (length=, ensure-list, recursively-empty-p): New. + (maybecall, exactly-one-p): New. + + * swank.lisp (arglist-for-echo-area): Adapted to take ``raw form + specs'' from Slime. + (parse-form-spec): New. Takes a ``raw form spec'' and returns a + ``form spec'' for further processing in Swank. Docstring documents + these two terms. + (split-form-spec): New. Return relevant information from a form spec. + (parse-first-valid-form-spec): Replaces `find-valid-operator-name'. + (find-valid-operator-name): Removed. + (operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'. + + (defstruct arglist): Add `any-p' and `any-args' slots to contain + arguments belonging to the &ANY lambda keyword. + (print-arglist): Adapted to also print &ANY args. + (print-decoded-arglist-as-template): Likewise. + (decode-arglist): Adapted to also decode &ANY args. + (remove-actual-args): Adapted to also remove &ANY args. + (remove-&key-args): Split out from `remove-actual-args'. + (remove-&any-args): New. Removes already provided &ANY args. + (arglist-from-form-spec): New. Added detailed docstring. + (arglist-dispatch): Dispatching generic function for + `arglist-from-form-spec' that does all the work. Renamed from + prior `form-completion'. + (arglist-dispatch) Added methods for dealing with declaration and + type-specifiers. + (complete-form): Adapted to take ``raw form specs'' from Slime. + (completions-for-keyword): Likewise. + (format-arglist-for-echo-area): Removed. Not needed anymore. + + * swank-backend.lisp (declaration-arglist): New generic + function. Returns the arglist for a given declaration + identifier. (Backends are supposed to specialize it if they can + provide additional information.) + (type-specifier-arglist): New generic function. Returns the + arglist for a given type-specifier operator. (Backends are + supposed to specialize it if they can provide additional + information.) + (*type-specifier-arglists*): New variable. Contains the arglists + for the type specifiers in Common Lisp. + + * swank-sbcl.lisp: Now depends upon sb-cltl2. + (declaration-arglist 'optimize): Specialize the `optimize' + declaration identifier to pass it to + sb-cltl2:declaration-information. + + +2007-08-23 Helmut Eller heller@common-lisp.net + + Some inspector cleanups. + + * slime.el (slime-inspect): Remove dwim stuff and drop keyword + args. + (slime-read-object): Killed. + (slime-open-inspector): Drop keyword args. Update callers + accodordingly, expect presentation related code. Presentations no + longer work in the inspector. + + * swank.lisp (*inspector-dwim-lookup-hooks*) + (default-dwim-inspector-lookup-hook): Deleted. + (init-inspector): Sanitize arglist. + (inspect-object): Don't return an :id for *inspectee-parts*. + + * swank-backend (type-for-emacs): Removed. No backend implemented + it. + +2007-08-23 Helmut Eller heller@common-lisp.net + + * slime.el (slime-fuzzy-upgrade-notice): New function. Bound to + the key where slime-fuzzy-complete-symbol used to be. + +2007-08-22 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-close-all-parens-in-sexp): Fix interplay with + `slime-close-parens-limit'. This should also affect + `slime-complete-form' (C-c C-s) in a positive way. + +2007-08-19 Helmut Eller heller@common-lisp.net + + * contrib: New directory. Move fuzzy completion code to that + directory. + + * swank.lisp (swank-require): New function to load contrib code. + (*find-module*, module-filename, *load-path*, merged-directory) + (find-module, module-canditates): New. Pathname acrobatics for + swank-require. + + * swank-loader.lisp: Compile (but don't load) contribs. + (*contribs*, contrib-source-files): New. + +2007-08-16 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-process-available-input): Correct yesterday's + change: the buffer a request was originally performed in doesn't + necessarily exist at this time anymore, so we check for buffer + liveness now. + + The problem arised when quitting in SLDB which would cause Swank + to send a `:debug-return' message before the acknowledgement + message for `sldb-quit' is sent. So the acknowledgement is + received in a context where the sldb-buffer is closed already. + +2007-08-15 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-process-available-input): Make sure that the + event received from SWANK is processed in the context of the + original buffer the request of the response was performed in. + Previously, the clauses of `slime-rex' were processed in the + internal *cl-connection* buffer. And as a result the continuations + passed to `slime-eval' and `slime-eval-async' ditto. + +2007-08-15 Tobias C. Rittweiler tcr@freebits.de + + Make `M-.' work on definitions outside the current restriction. + `M-,' will also properly restore the narrowing as of before the + jump. Similiarly for quiting from the compilation notes buffer and + the Xref buffers. + + * slime.el (slime-narrowing-configuration, slime-emacs-snapshot), + (current-slime-narrowing-configuration), + (set-slime-narrowing-configuration), + (current-slime-emacs-snapshot), + (set-slime-emacs-snapshot), + (current-slime-emacs-snapshot-fingerprint): New. Emacs' window + configurations do not restore narrowing, so introduce a + snapshot facility that contains the necessary information. + + * slime.el: Various renaming and adaptions in the Slime temp + buffer, xref, goto-definition and compilation notes section to use + the newly introduced snapshots instead of mere window + configurations. + + * slime.el: (slime-highlight-notes, slime-remove-old-overlays): + Still operate on whole buffer, but restore previous restriction if + there was any. + (slime-goto-location-position): Now widens the buffer to properly + jump to definitions outside of the current restriction. + + * slime.el (slime-push-definition-stack), + (slime-pop-find-definition-stack): Now also stores information + about narrowing on the definition stack, in order to properly + restore narrowing on `M-,'. + + * slime.el (def-slime-test narrowing): Test case for properly + dealing with narrowing. + + * slime.el (slime-buffer-narrowed-p): New function, tests whether + the current buffer is narrowed or not. + (save-restriction-if-possibly): Like `save-restriction', but not + as strict---see doc string. + + * slime.el (slime-length=): New function; semantically the same + as (= (length seq) n), but more efficiently implemented for lists. + Changed the above pattern into a call to SLIME-LENGTH= where + appropriate. + +2007-08-05 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * swank.lisp (backtrace): Handle printer errors while printing a + frame. This makes debugging print-object methods with SLIME + easier. Reported by Utz-Uwe Haus. + +2007-08-02 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-kill-all-buffers): Now also kills all buffers + beginning with a `*SLIME' prefix (like, for instance, `*SLIME + Apropos*', or `*SLIME macroexpansion*'.) + +2007-06-28 Helmut Eller heller@common-lisp.net + + * slime.el (def-slime-selector-method): Revert Marco's change from + 2007-05-23. BODY can return a buffer name, like "*slime-events*". + Handle that and never ignore invalid return values. Force BODY to + abort if there's no suitable buffer. Why would you want to switch + buffers if the desired buffer doesn't exist? + +2007-06-27 Tobias C. Rittweiler tcr@freebits.de + + Fixing `C-c M-q' at the REPL. Thanks to Andr� Thieme for pointing + out that it has been broken since several months. + + * slime.el (slime-reindent-defun): Use functions + `slime-beginning-of-defun' and `slime-end-of-defun' that were + introduced in the last changeset. + +2007-06-16 Tobias C. Rittweiler tcr@freebits.de + + * slime.el: Pressing `C-M-a' (beginning-of-defun) in midst of the + last REPL prompt directs the cursor to the beginning of the + prompt. Pressing it again, would do nothing; now it moves the + cursor to the start of the previous prompt (as it's consistent + with the behaviour when the cursor was placed midst one of the old + prompts.) + + Likewise for `C-M-e' (end-of-defun) + + Additionally fixing `C-c C-s' (slime-complete-form) at the REPL. + + (slime-keys): New bindings for `C-M-a' and `C-M-e' to + SLIME-BEGINNING-OF-DEFUN and SLIME-END-OF-DEFUN respectively. + (slime-keys): Making `C-c C-q' (slime-close-parens-at-point) + obsolete, as it didn't work correctly on the REPL. + (slime-repl-mode-map): Removed bindings for `C-M-a' and `C-M-e', + as they're now inherited from SLIME-KEYS. + (slime-repl-beginning-of-defun, slime-repl-end-of-defun): Jump to + the previous (next) prompt if called twice in a row. + + (slime-close-parens-at-point): Commented out. + (slime-close-all-sexp): Renamed to SLIME-CLOSE-ALL-PARENS-IN-SEXP. + (slime-close-all-parens-in-sexp): Modified to take + SLIME-CLOSE-PARENS-LIMIT into account. + (slime-complete-form): Use SLIME-CLOSE-ALL-PARENS-IN-SEXP. + + +2007-05-24 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp: Fixed regression in completion: "swank[TAB]" would + previously be completed to "swank-backend:"; "get-internal[TAB]" + would be completed to "get-internal-r-time" (instead of simply + "get-internal-r"); and "custom:*comp[TAB]" would be completed to + "custom:*compiled-" on CLISP, even though there's a + "custom:*complile-". + + Thanks to Ken Causey for helping me find the first two. + + (completions): Revert changes from 2007-05-11. + (longest-compound-prefix): Fixed to properly generate a compound + _prefix_. + +2007-05-23 Marco Baringer mb@bese.it + + * slime.el (def-slime-selector-method): Allow the selector body to + not return a buffer. This means that, instead of being to forced + to signal an error when a choosen buffer can't be found (like + choosing d when there are no debugger buffers) can simply display + a message. + + Fix handling of auto-flushing on sbcl: + + * swank-sbcl.lisp (*auto-flush-interval*): New variable + controlling how often streams are flushed. + (*auto-flush-lock*): New lock guarding access to the shared + variable *auto-flush-streams*. + (make-stream-interactive): Wrapped access to *auto-flush-streams* + in a call-with-recursive-lock-held. + (flush-streams): Wrapped in call-with-recursive-lock-held. + +2007-05-17 Martin Simmons martin@lispworks.com + + * swank-lispworks.lisp (lispworks-inspect): Fix hanging caused by + mapcan, i.e. nconc, on a constant list returned by + label-value-line. + +2007-05-17 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-complete-form): Only insert a closing + parenthesis if the form is not already closed. Reported by and + adapted from Mac Chan. + +2007-05-17 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp: Fixed bug in completion as previously "swank:[tab]" + would correctly list all the symbols in SWANK, but would + simultaneously append a spooky dash to the original + string ("swank:-"). + + (completions): Strip off the package identifier part, and only + compute the longest compound prefix for the actual symbol + identifiers. + (untokenize-symbol): New function. Inverse of TOKENIZE-SYMBOL. + (format-completion-result): Use UNTOKENIZE-SYMBOL. + +2007-05-17 Dustin Long dlong@stevens.edu + + * swank-ecl.lisp (compile-from-stream): Fixed typo that prevented + `slime-compile-defun' from actually compiling a function. + +2007-05-17 Tobias C. Rittweiler tcr@freebits.de + + * swank-loader.lisp (*sysdep-files*): Load the auxiliary files + swank-source-*.lisp before swank-sbcl.lisp to avoid + undefined-function style warnings. + +2007-05-16 Takehiko Abe keke@gol.com + + * swank.lisp (inspect-for-emacs file-stream, stream-error): Fixed + typo in keyword arg; it's `:refreshp', not `:refresh'. + +2007-05-14 Tobias C. Rittweiler tcr@freebits.de + + * slime.el: Fixed proper handling of the abortion of a + request. (For instance, when calling (SWANK::ABORT-REQUEST "FOO") + from the REPL.) + + (sldb-quit): Updated the DESTRUCTURE-CASE clause for (:abort) to + take an argument. + (sldb-continue): Likewise. + (sldb-invoke-restart): Likewise. + (sldb-break-with-default-debugger): Likewise. + (sldb-return-from-frame): Likewise. + (sldb-restart-frame): Likewise. + (slime-repl-eval-string) Likewise. + (slime-repl-show-abort): Now also inserts the reason for the abort + into the REPL buffer. + + * swank.lisp (eval-for-emacs): Remove code that would suggest that + it's possible to use the rex `(:abort ...)' with more than one + argument. + +2007-05-14 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp: Liberated from unnecessary style-warnings! + + (eval-for-emacs): Don't use SLOT-VALUE on condition objects! + (inspect-bigger-piece-actions): Changed from DEFMETHOD to DEFUN. + (inspect-whole-thing-action): Likewise. + (inspect-show-more-action): Likewise. + (make-symbols-listing): Adds an explicit DEFGENERIC. + (menu-choices-for-presentation): Likewise. + + (make-symbols-listing (eql :classification)): Use `(loop for k + being EACH hash-key ...)' rather than `(loop for k being THE + hash-key)', to omit the justified style-warning from CLISP. + +2007-05-14 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp (package-names): Make sure to return a fresh list. + (fuzzy-find-matching-packages): Use PACKAGE-NAMES. + (list-all-package-names): Use PACKAGE-NAMES. + +2007-05-13 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-pretty-lambdas): Removed. If you really want + this, please use one of the external ressources that provide this; + for instance, `pretty-lambda.el', `pretty-greek.el', or even + `pretty-symbols.el'. For more information, please see + + http://www.emacswiki.org/cgi-bin/wiki/PrettyLambda + +2007-05-11 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp (fuzzy-find-matching-symbols): Modified to take + package nicknames into account. Previously, fuzzy completing on + nicknames did (except for some incidental cases) not work. Thanks + to Lu�s Oliveira and Attila Lendvai for pointing that out. + +2007-05-11 Tobias C. Rittweiler tcr@freebits.de + + Removed support for completing to the longest compound pre- and + suffix with the default completion method (C-c TAB, or just TAB on + the REPL), because it has been causing trouble all the time, but + didn't offer any real advantage besides niftiness. E.g.: + + previous behaviour: + + asdf:*com TAB => asdf:*compile-file--behaviour* + + now simply: + + asdf:*com TAB => asdf:*compile-file- + + For discussing on this subject, please see the mail with + message-id 87y7l53lch.fsf@freebits.de that was posted to + slime-devel 2007-04-06, or alternatively: + + http://common-lisp.net/pipermail/slime-devel/2007-April/006087.html + + * swank.lisp (make-compound-prefix-matcher): New function. + Abstracted from COMPOUND-PREFIX-MATCH. + (compound-prefix-match): Use MAKE-COMPOUND-PREFIX-MATCHER. + (compound-prefix-match/ci/underscores): Removed. + + (longest-completion): Renamed to LONGEST-COMPOUND-PREFIX. Changed + to only return a compound prefix, instead of a concatenation of a + compound prefix and a compound suffix. Added an &optional + parameter to specify what delimeter the passed string is + compounded with. + (tokenize-completion): Takes additional parameter to specify the + delimeter for tokenization. + (longest-completion/underscores): Removed; not needed anymore. + (tokenize-completion/underscores): Likewise. + (untokenize-completion/underscores): Likewise. + + (completions): Slight docstring modification, also added an + examplary use case; use LONGEST-COMPOUND-PREFIX instead of + LONGEST-COMPLETION. + (completions-for-character): Use LONGEST-COMPOUND-PREFIX, and + MAKE-COMPOUND-PREFIX-MATCHER. + (completions-for-keyword): Use LONGEST-COMPOUND-PREFIX. + +2007-05-11 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp (apropos-symbols): Really use MAKE-REGEXP-MATCHER. + +2007-05-10 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp: Previously when using SLIME-APROPOS-PACKAGE, only + those symbols were considered whose home package matched the + given package; this would, however, prevent all those symbols from + being listed that are imported from another package, and then + exported again in the package they got imported into. (As an + example, SWANK:RESTART-FRAME is actually from SWANK-BACKEND.) + + (apropos-matcher): Renamed to MAKE-REGEXP-MATCHER. + (make-regexp-matcher): Changed to only match for a given regexp. + (apropos-symbols): Use MAKE-REGEXP-MATCHER. + +2007-05-10 Tobias C. Rittweiler tcr@freebits.de + + * slime.el: Fix macroexpanding on things like ",(loop ...)". + + (slime-sexp-at-point-for-macroexpansion): New function; like + SLIME-SEXP-AT-POINT-OR-ERROR, but fixes up some misbehaviour with + respect to macroexpansion. + (slime-eval-macroexpand, slime-eval-macroexpand-inplace): Use the + new function. + +2007-05-10 Tobias C. Rittweiler tcr@freebits.de + + * slime.el: Within the Slime Inspector, `S-Tab' will now also work + on X. Furthermore `Tab' and `S-Tab' will now correctly wrap + around the beginning and end of the buffer; priorly it'd hang on + the beginning with a message "Beginning of buffer", and would + require an additional `S-Tab'. + + (slime-inspector-mode-map): Attached `[backtab]' to + SLIME-INSPECTOR-PREVIOUS-INSPECTABLE-OBJECT, as Emacs translates + `S-Tab' to `Backtab' on X. + (slime-find-inspectable-object): New function; finds next or + previous inspectable object. + (slime-inspector-next-inspectable-object): Mostly rewritten. Use + SLIME-FIND-INSPECTABLE-OBJECT to make the code clearer. + +2007-04-19 Tobias C. Rittweiler tcr@freebits.de + + * swank-backend.lisp (label-value-line): Add :newline as &key + argument; if true (the default) inserts a newline. + + * swank.lisp (inspect-for-emacs-list): Don't add a newline after + the last value of the list. + +2007-04-18 Marco Baringer mb@bese.it + + * swank.lisp (log-event): Setup the printer so that, no matter + what the global values of the *print-XYZ* variables, this function + works as expected. + (*debug-on-swank-error*): New variable. + (defpackage :swank): Export *debug-on-swank-error*. + (with-reader-error-handler): When *debug-on-swank-error* is + non-nil drop into a debugger. + (dispatch-loop): Idem. + +2007-04-17 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp: Instead of just having all the symbols of a package + listed alphabetically in the inspector page recently introduced + for that purpose, add a button to that page to group them by their + classification. + + (%package-symbols-container): New slot GROUPING-KIND. + (%make-package-symbols-container): New function; wraps around + %%MAKE-PACKAGE-SYMBOLS-CONTAINER, which will actually create the + structure. We need this, to make GROUPING-KIND an entirely + internal affair. + + (make-symbols-listing): New generic function to dispatch on + GROUPING-KIND. + (make-symbols-listing :symbol): Just the stuff that was priorly + wired into INSPECT-FOR-EMACS (%PACKAGE-SYMBOLS-CONTAINER). + (make-symbols-listing :classification): New; returns the passed + symbols grouped by their classification. + (inspect-for-emacs %package-symbols-container): Most code split + off into MAKE-SYMBOLS-LISTING. + +2007-04-17 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp (swank-compiler): Fix the return value to always be a + list of two elements even if the abort restart is invoked which + originally just returned NIL. (Which wouldn't play with the recent + change to use DESTRUCTURING-BIND in SLIME-COMPILATION-FINISHED.) + +2007-04-17 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp (inspect-for-emacs %package-symbols-container): + Revert Marco's change from 2007-04-08; he had the good idea of + adding a facility to jump to the relevant source line of a symbol, + but `M-.' is already bound to SLIME-FIND-DEFINITION in the + inspector, which is a nicer way of doing this alltogether. + +2007-04-16 Takehiko Abe keke@gol.com + + * swank-openmcl.lisp (accept-connection, find-external-format): + utf-8 support. + +2007-04-16 Marco Baringer mb@bese.it + + * slime.el (slime-with-xref-buffer): Added missing , + +2007-04-16 Tobias C. Rittweiler tcr@freebits.de + + * slime.el: Pressing `q' in *compiler notes* after a `C-c C-k' or + `C-c M-k' would not probably restore the original window + configuration. Fix that. + + (slime-get-temp-buffer-create): New &key arg WINDOW-CONFIGURATION. + (slime-with-xref-buffer): Likewise. + + (slime-compilation-finished): New &optional arg WINDOW-CONFIG. + (slime-maybe-show-xrefs-for-notes): Likewise. + (slime-show-xrefs) Likewise. + (slime-maybe-list-compiler-notes): Likewise. + (slime-list-compiler-notes): Likewise. + + (slime-compilation-finished-continuation): Renamed to + SLIME-MAKE-COMPILATION-FINISHED-CONTINUATION. + + (slime-make-compilation-finished-continuation): Now takes two + args, the current buffer and optionally the current window config + to be restored. + + (slime-compile-file): Save current window configuration before + popping up the REPL for compilation output, pass it down. + (slime-easy-menu): Add entry for SLIME-UNTRACE-ALL. + +2007-04-16 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp (fuzzy-find-matching-packages): Fix a small typo that + prevented interpreting NIL as the argument TIME-LIMIT-IN-MEC to + mean an infinite time limit. This bug propagated up to explicit + calls to FUZZY-COMPLETIONS, like + (swank:fuzzy-completions "mvb" "COMMON-LISP") => (NIL, T) + + (format-fuzzy-completions): Renamed to FORMAT-FUZZY-COMPLETION-SET + + (format-fuzzy-completion-set): Accomodated to recent changes of + the return value of FUZZY-COMPLETIONS; changed the docstring to + make it explicit that this function is supposed to take the return + value of FUZZY-COMPLETION-SET. + + * slime.el (slime-compilation-finished): Don't use + MULTIPLE-VALUE-BIND for list destructuring, only because multiple + values happen to be implemented via lists in elisp! + (slime-fuzzy-completions-mode): Added an detailed explanation to + the docstring of how Fuzzy Completion works and how it'ss supposed + to be worked with. + (slime-fuzzy-explanation): Shortened to reference to + SLIME-FUZZY-COMPLETIONS-MODE for help on fuzzy completion. + (slime-fuzzy-choices-buffer): Set BUFFER-QUIT-FUNCTION to + SLIME-FUZZY-ABORT to make it correctly exit fuzzy completion when + pressing `Esc Esc Esc' (`M-Esc Esc'). + +2007-04-12 Nikodemus Siivola nikodemus@random-state.net + + * swank-sbcl.lisp (emacs-buffer-source-location): Add &allow-other-keys + to the descructuring of the source location plist in order to accept + :emacs-directory. + +2007-04-09 Marco Baringer mb@bese.it + + * swank.lisp (inspector-content-for-emacs): Look for refresh + keyword argument in :action links. + (inspect-whole-thing-action, inspect-show-more-action): Update for + new :action argument handling. + (inspect-for-emacs stream, inspect-for-emacs stream-error): Pass + :refresh nil on :action links. + (action-part-for-emacs): Set both lambda and refresh in the + *inspectee-actions* array. + (inspector-call-nth-action): *inspectee-actions* now holds both + the function and the boolean specifying whether to refresh or not. + + * swank-backend.lisp (inspect-for-emacs): Docstring update. + + * slime.el (slime-inspector-operate-on-point): Allow the action + calls to return nil. + +2007-04-08 Marco Baringer mb@bese.it + + * .cvsignore: Added *.lx64fsl (openmcl on linux fasls). + +2007-04-08 Marco Baringer mb@bese.it + + * swank.lisp (inspect-for-emacs): Added 'jump to source' action + for symbols in the new package-symbol browser. + +2007-04-08 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp: Implemented a new special inspector page for + displaying internal (external, &c) symbols that display + classification flags additionally to each symbol, similiar to the + content of a *Fuzzy Completion* buffer. Furthermore, added the + possibility to display all symbols that are /present/ in a + package. Combined with cleanup of the code parts in question. + + (symbol-status): New function. Returns the status of a symbol in a + given package (:internal, :external &c.) + + (symbol-external-p): Adapted to use new function SYMBOL-STATUS. + + (symbol-classification->string): New function. Converts a list of + classification flags into a concise string representation. + + (%package-symbols-container): New struct. We need a unique type to + dispatch in INSPECT-FOR-EMACS for the new inspector page, use this + as a wrapper structure. + + (inspect-for-emacs package): Reorganized to not cause too much eye + cancer; now with a saner maximum column width. Changed to make use + of new SYMBOL-STATUS, for code reuse. Also changed to make use of + new %PACKAGE-SYMBOLS-CONTAINER to let a new page pop up in Emacs + if the user wants to access the list of symbols of the package. + Added such a possibility to access all `present' symbols. + + (inspect-for-emacs %package-symbols-container): New method. + Displays all symbols wrapped up in the container structure + combined with their classification flags as determined by + CLASSIFY-SYMBOL. + +2007-04-08 Lu�s Oliveira loliveira@common-lisp.net + + * swank-backend.lisp (compute-sane-restarts): New interface. + * swank-clisp.lisp: Fix tabs and trailing whitespace. + (compute-sane-restarts): Implement new interface. + +2007-04-08 Takehiko Abe keke@gol.com + + * swank-openmcl.lisp (xref-locations): + +2007-04-08 Marco Baringer mb@bese.it + + * swank.lisp (fuzzy-completion-set): Use two check-type forms + instead of a place like (values limit time-limit-in-msec). While + sbcl seems to accept this form openmcl doesn't and it's not clear + from the spec that this is allowed. + +2007-04-07 Harald Hanche-Olsen hanche@math.ntnu.no + + * slime.el (sldb-mode-map): Added key definition for follow-link. + +2007-04-06 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp: Making fuzzy completion regard the time limit + correctly. Also make it properly use microseconds as time + granularity and inform the Emacs side if the time limit has + exhausted. Additionally, over all minor and cosmetic changes: + + (fuzzy-completions, fuzzy-completion-set): Returns now + additionally a flag indicating whether the time limit has + exhausted under the hood. Accomodated docstring accordingly. + + (fuzzy-create-completion-set): Changed to correctly catch and + propagate the remaining time limit to the actual match functions, + and return once time limit has exhausted. Some aesthetical code + reorganization. + + (get-real-time-in-msecs): New function. + + (fuzzy-find-matching-symbols, fuzzy-find-matching-packages): + Correctly regard the time limit. Use new function + GET-REAL-TIME-IN-MSECS for that purpose. Return the remaining + time limit as second value. + + * slime.el (slime-fuzzy-complete-symbol): Accomodated to deal with + the additionally returned flag of SWANK:FUZZY-COMPLETIONS. Pass + the flag by. + (slime-fuzzy-choices-buffer): Pass interruption flag by. + (slime-fuzzy-fill-completions-buffer): If time limit has exhausted + during completion retrieval, show an informational indication as + last entry in *Fuzzy Completion*. + (slime-fuzzy-last): New variable. To hold the last real completion + choice previous to the (possible) Time Limit Exhausted information. + (slime-fuzzy-next): Accomodated to not go beneath SLIME-FUZZY-LAST. + +2007-04-06 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp (tokenize-symbol, tokenize-symbol-thoroughly): + Previously these functions said a string representing a symbol is + internal exactly if it contained "::" as substring. Now they say + additionally so for symbols without any package identifier, as + they are internal to am implicit current package. (Otherwise + will break fuzzy completion.) + + (tokenize-symbol): Added docstring. + + * swank.lisp (format-completion-result): Fixed formation + for the case that PACKAGE-NAME is NIL but INTERNAL-P is T. + +2007-04-06 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp: Making fuzzy completion semantically right from a + user perspective. As an example on SBCL, "sb:with- C-c M-i" will + display all exported "with"-style macros in all sb-* packages from + now on. :) + + (parse-completion-arguments): Replacing with a semantically-sound + implementation, as the previous one was a bit confused. Clarifying + docstring. Adding commentary table of various constellations of + returned values for thorough explanation. + + (carefully-find-package): Removed. Obsolete by above change. + + (defstruct fuzzy-matching): Introduced to make internally-used + datastructure explicit. Distinguishing ``completion chunks'' + between those pertaining to the symbol itself and those to the + package identifier. + + (convert-fuzzy-completion-result): Renamed to + FUZZY-CONVERT-MATCHING-FOR-EMACS. + + (fuzzy-convert-matching-for-emacs): Accomodating for the new + datastructure. Only the chunks pertaining to the symbol itself are + fixed up positionally, the package-chunks are untouched. + Necessary for letting package identifiers be highlighted within + *Fuzzy Completions* in cases like "sb:with- C-c M-i." + + (fuzzy-completion-set): Taking out most code to become new + function FUZZY-CREATE-COMPLETION-SET. + + (fuzzy-create-completion-set): Doing all the hard work. Crux of + this changeset. so to speak. Largly rewritten to accomodate all + different cases of PARSE-COMPLETION-ARGUMENT. + + (fuzzy-find-matching-symbols, fuzzy-find-matching-packages): + Accomodating to new datatstructure FUZZY-MATCHING. Adapting + docstring accordingly. + + * swank-backend.lisp: Export WITH-STRUCT. + + * swank.lisp (eval-for-emacs, fuzzy-completions): + Various trivia like fixing spelling and indentation. + +2007-04-06 Tobias C. Rittweiler tcr@freebits.de + + * slime.el (slime-fuzzy-highlight-current-completion): Fix + off-by-one error that causes the currently selected + completion in the *Fuzzy Completion* buffer be highlighted + one char too far. + +2007-04-06 Tobias C. Rittweiler tcr@freebits.de + + * swank.lisp: Cleanup of parts of the fuzzy completion code. + Additionally a couple of enhancements. As follows: + + (fuzzy-completions, fuzzy-completion-selected): Minor + stylistic and clarifying modifications of the docstrings. + + (fuzzy-find-matching-symbols): Huge code reorganization. + Organizing relevant code into local function TIME-EXHAUSTED-P, + renaming local function SYMBOL-MATCH to PERFORM-FUZZY-MATCH, + making previously required argument EXTERNAL to new &key + argument :EXTERNAL-ONLY, clarifying docstring. + + (fuzzy-find-matching-packages): Making its return value + conformant to that of FUZZY-FIND-MATCHING-SYMBOLS, i.e. + instead of returning, among others, a package's name as + string, it now returns a symbol representing the package. + Accomodates the docstring accordingly. + + (fuzzy-completion-set): Minor typographical fix in docstring. + Changing local function CONVERT to use MAP-INTO instead of + doing it essentially manually. Accomodating to changes of + FUZZY-FIND-MATCHING-SYMBOLS, resp. -PACKAGES. + + (fuzzy-completion-set): Additional new feature: + The returned completions are sorted alphabetically by the + matched completion string before sorted by its score. + Affects especially the list of all possible completions when + the user hits fuzzy-completion on an empty string within Emacs; + also makes the potential limitness of the listed completions + clearer to the end user of SLIME. + + (classify-symbol): New function. Returns a list with keywords + that classifies a given symbol. (E.g. :BOUNDP, :MACRO &c) + Supersedes parts of CONVERT-FUZZY-COMPLETION-RESULT, + implementing them in a more straightforward and proper way; + removes prior KLUDGE in that part of the original function. + + (convert-fuzzy-completion-result): The above changes made + it possible to simplify this function drastically. Now uses + the newly introduced function CLASSIFY-SYMBOL. + + * slime.el: Minor stylistic changes. Additionally: + (slime-fuzzy-insert-completion-choice): + (slime-fuzzy-fill-completions-buffer) : Adding use of the + :PACKAGE classification flag returned by SWANK:FUZZY-COMPLETIONS. + This flag is called "p". + +2007-04-06 Neil Van Dyke neil@neilvandyke.org + + * slime.el (sldb-insert-frame): Added mouse-face to frame label + and expression in Backtrace. + (sldb-insert-frames): Added mouse-face to "--more--" label in + Backtrace. + +2007-04-06 Michael Weber michaelw+slime@foldr.org + + * slime.el (slime-call-defun): insert the closing parenthesis for + the form. + +2007-04-06 Marco Baringer mb@bese.it + + * swank-openmcl.lisp (package swank-mop): Added + slot-makunbound-using-class. + +2007-03-29 Nikodemus Siivola nikodemus@random-state.net + + * swank-sbcl.lisp (swank-compile-string): save the original + directory into the source plist as :emacs-directory. + (make-definition-source-location): use the :emacs-directory from + the source plist and guess-readtable-for-filename to determine the + correct readtable for string-compiled definitions. + +2007-03-29 Nikodemus Siivola nikodemus@random-state.net + + * swank.lisp (*macroexpand-printer-bindings*): add *print-lines* + to defaults (NIL). + (find-definitions-for-emacs): use unless instead of cond. + +2007-03-25 Douglas Crosher dcrosher@common-lisp.net + + * slime.el (with-selected-window): define for compatibility with + Emacs 21. + +2007-03-24 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * swank.lisp (menu-choices-for-presentation): Offer a + "disassemble" menu item for functions. + +2007-03-24 Helmut Eller heller@common-lisp.net + + * slime.el (slime-read-port-and-connect): Fix race condition: + retry one more time if the port file is empty. Pop up the debugger + on other errors. + (slime-attempt-connection): Moved to toplevel. + (slime-timer-call): New. Used by slime-attempt-connection. + (slime-cancel-connect-retry-timer): New. + (slime-abort-connection): Use it. + (slime-repl-insert-prompt): Use insert-before-markers. This fixes + some redisplay problems, but I don't know why. Also: remove the + timer for async output. + (slime-repl-move-output-mark-before-prompt): Removed. + (slime-repl-save-merged-history): Use with-temp-message. + (slime-goto-location-buffer): Support Zip files. + (sldb-quit): Don't print "Evaluation aborted". + +2007-03-22 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime.el (slime-scratch-buffer): Respect the syntax text + properties of presentations. + +2007-03-21 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * swank.lisp (lookup-presented-object): The presentation id of + frame locals now includes the thread id; ignore it for now. + + * slime.el (slime-copy-presentation-at-mouse-to-point): Manually + invoke the after-change function, so that the presentation overlay + is created even if we paste to non-REPL buffers. + (slime-menu-choices-for-presentation): Evaluate + menu-choices-for-presentation-id in the right buffer, thus in the + right Lisp thread. Reported by Attila Lendvai. + (slime-menu-choices-for-presentation): Show the id of the presentation. + (sldb-insert-locals): Include the thread id in the presentation id. + +2007-03-21 Helmut Eller heller@common-lisp.net + + * slime.el (slime-repl-eval-string, slime-repl-insert-result): + Support the presentation-less old protocol. + (slime-goto-location-position): Use column number if available. + +2007-03-20 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * swank.lisp (completion-output-symbol-converter): Fix completion + for mixed-case symbols that need escaping in readtable-case + :upcase or :downcase. + + * slime.el (slime-copy-presentation-at-mouse-to-point) + (slime-copy-presentation-at-mouse-to-kill-ring): New commands. + (slime-menu-choices-for-presentation): Change interface. New + menu options, Copy to kill-ring, Copy to point. + (slime-presentation-menu): Change call to + slime-menu-choices-for-presentation. + +2007-03-20 Takehiko Abe keke@gol.com + + * swank-openmcl.lisp (hash-table-weakness): fix typo + +2007-03-14 Christophe Rhodes csr21@cantab.net + + * slime.el (slime-search-suppressed-forms): handle multiple + conditionals on the same line. + +2007-02-26 Nikodemus Siivola nikodemus@random-state.net + + * swank.lisp (inspect-for-emacs): Add support for inspecting + non-decodable float entities like NaNs and infinities. + +2007-02-25 Tobias C. Rittweiler tcr@freebits.de + + * swank-backend.lisp (inspect-for-emacs): Remove reference to + inexistent argument from docstring. + +2007-02-25 Harald Hanche-Olsen hanche@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. Some strings are still there. + +2007-02-25 Helmut Eller heller@common-lisp.net + + * slime.el (slime-delete-swank-port-file): Don't use + display-warning; that's not available everywhere. + (slime-repl-update-banner): Insert the date only if the buffer is + empty. + (slime-list-compiler-notes): Fetch the notes only if called + interactively. + (slime-set-query-on-exit-flag): New function, to avoid compiler + warnings about obsolete function process-kill-without-query. + (slime-defun-if-undefined): Perform the test at runtime not at + compile time. Reported by Lennart Staflin. + + * swank.lisp (guess-package): Renamed from + guess-package-from-string. + (set-package): Use it. + +2007-02-22 Juho Snellman jsnell@iki.fi + + * slime.el (slime-start-lisp): Don't cd if no directory was specified. + (slime-maybe-start-lisp): Pass directory argument to slime-start-lisp + also in other cond branch. + (slime-restart-sentinel): Pass a NIL directory to slime-start-lisp. + +2007-02-21 Marco Baringer mb@bese.it + + * slime.el (slime-start): Added :directory argument and pass it to + slime-maybe-start-lisp. + (slime-maybe-start-lisp): Added directory argument and pass it to + slime-start-lisp (but not slime-reinitialize-inferior-lisp-p) + (slime-start-lisp): Added directory argument. Used to set buffer's + directory before starting the inferior lisp. + +2007-02-17 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime.el (slime-find-tag-if-tags-table-visited): New function. + (slime-edit-definition-fallback-function): Offer it as a value + for customization. + +2007-02-05 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime.el (sldb-insert-locals): Repair presentation markup of + frame locals. + +2007-02-04 Antonio Menezes Leitao aml@gia.ist.utl.pt + + * swank-lispworks.lisp (dspec-file-position): Bind + *compile-file-pathname*, *compile-file-truename*, *load-pathname* + and *load-truename* in dspec-file-position. + +2007-02-04 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime.el (slime-write-string): When writing a :repl-result, + update the slime-output-end marker for the purpose of asynchronous + output (when *use-dedicated-output-stream* is true). + Reported by Madhu enometh@meer.net. + +2007-02-03 Marco Baringer mb@bese.it + + * slime.el (slime-delete-swank-port-file): Fix typo in + warning message. + +2007-02-02 Marco Baringer mb@bese.it + + Warn, as opposed to bailing out with an error, when deleting the + port file fails. Patch by: Samium Gromoff + _deepfire@feelingofgreen.ru + + * slime.el (slime-delete-swank-port-file): New function. + (slime-inferior-connect): Use slime-delete-swank-port-file. + (slime-read-port-and-connect): Use slime-delete-swank-port-file. + +2007-01-31 Marco Baringer mb@bese.it + + * slime.el (slime-repl-update-banner): Restore animation. + (slime-startup-animation): restore. + +2007-01-30 Helmut Eller heller@common-lisp.net + + * slime.el (slime-complete-symbol-function): Restore old default. + (set-keymap-parents): Deleted. + (slime-startup-animation): Deleted. + (slime-read-from-minibuffer): Don't use defun*. + (slime-repl-terminate-history-search): New. + (slime-repl-next-matching-input): Use it. + + * slime-autoloads.el: New file. + +2007-01-29 Sean O'Rourke sorourke@cs.ucsd.edu + + * slime.el (slime-start): Continue even if the user, after + prompting, didn't recompile the stale .elc file. + (slime-urge-bytecode-recompile) [xemacs]: Abort immediately if the + user doesn't want to continue. + (slime-recompile-bytecode): Don't use byte-compile-warning-types; + it may not exist in XEmacs. + +2007-01-24 Helmut Eller heller@common-lisp.net + + * slime.el (sldb-recenter-region): Use count-screen-lines instead + of count-lines. + + * swank.lisp (unparse-name): New function. + (list-all-package-names): Use it. This fixes a bug related to + readtable-case and makes package name completions look prettier. + Suggested by Harald Hanche-Olsen hanche@math.ntnu.no. + +2007-01-24 Bill Clementson billclem@gmail.com + + * slime.el (slime-call-defun): Put the docstring before + the (interactive) form so that "C-h f slime-call-defun" will + return it. + + * slime.el (slime-scratch-mode-map): Changed parent keymap to + lisp-mode-map to prevent unnecessary duplication of slime-mode-map + bindings and so that lisp-mode-map key bindings are present in the + slime scratch buffer. Change identified by Ariel Badichi. + +2007-01-20 Luke Gorrie luke@synap.se + + * slime.el (slime): Use COMMAND and CODING-SYSTEM parameters + Previously they were ignored. + +2007-01-17 Christian Lynbech christian.lynbech@ericsson.com + + * slime.el (slime-init-command): Use expanded files when writing + the LOAD form for swank. + +2007-01-14 Helmut Eller heller@common-lisp.net + + * slime.el: Cleanups for the repl history code. + (slime-repl-mode-map): Don't shadow M-C-d. + (slime-repl-history-replace): Simplified. + (slime-repl-history-search-in-progress-p): New. + (slime-repl-position-in-history): If there's no match return + out-of-bound positions instead of nil. + (slime-repl-add-to-input-history): Never modify the argument. + (slime-repl-previous-input): Renamed from + slime-repl-previous-input-starting-with-current-input. + (slime-repl-next-input): Renamed from + slime-repl-next-input-starting-with-current-input + (slime-repl-forward-input): Renamed from slime-repl-next-input. + (slime-repl-backward-input): Renamed from + slime-repl-previous-input. + (slime-repl-history-pattern): Renamed from + slime-repl-matching-input-regexp. + (slime-repl-delete-from-input-history): Simplified. + + (slime-repl-history-map) + (slime-repl-history-navigation-neutral-commands) + (slime-repl-jump-to-history-item) + (slime-repl-previous-or-next-input) + (slime-repl-starting-with-current-input-regexp) + (slime-repl-continue-search-with-last-pattern) + (slime-repl-previous-or-next-matching-input): Deleted. + + (sldb-list-locals, sldb-list-catch-tags): Deleted. Aren't of much + use anymore. + +2007-01-12 Helmut Eller heller@common-lisp.net + + * swank-clisp.lisp: Better classification on frames on the stack. + Make variables in eval frames accessible to the debugger. + (frame-type, *frame-prefixes*, frame-to-string, is-prefix-p) + (frame-string-type, boring-frame-p): New. + (%frame-count-vars, %frame-var-name, %frame-var-value) + (frame-venv, next-venv, venv-ref, %parse-stack-values): Replaces + old frame-do-venv. + (extract-frame-line, extract-function-name, split-frame-string) + (string-match): New code to print frames. + (frame-locals, frame-var-value): Use the new stuff. + + (inspect-for-emacs): Fix various bugs. + + * swank-loader.lisp (compile-files-if-needed-serially): Don't wrap + everything in a compilation unit. If we abort on load errors and + it is confusing to see compiler warnings after the abort message. + (handle-loadtime-error): CLISP's format implements ~< differently + as everybody else, so use a explicit pprint-logical-block instead. + + * swank.lisp (list-all-systems-in-central-registry): Don't + reference asdf directly, that leads to read errors in some + systems. + +2007-01-12 Juho Snellman jsnell@iki.fi + + * slime.el (slime-read-expression-map): Switch the slime-mode-map + and minibuffer-local-map back the way they were. The previous change + was made due to a misunderstanding, caused by a keybinding for + [(return)] apparently being more specific than one for (kbd "RET"), + even when the former is in a parent keymap and the latter in the + child. + +2007-01-12 Helmut Eller heller@common-lisp.net + + * swank.lisp (handle-request): Use 'abort as restart name, but + bind *sldb-quit-restart* to the restart returned by find-restart. + Also use a slighly friendlier message, because newbies seem to + invoke the ABORT restart instead of pressing q in the debugger. + +2007-01-12 Edi Weitz edi@agharta.de + + * slime.el (slime-find-asd): Remove file extension. + + (slime-read-system-name): Use SWANK:LIST-ASDF-SYSTEMS. + + * swank.lisp (list-all-systems-in-central-registry): Use only + pathname name. + + (list-all-systems-known-to-asdf): New function. + + (list-asdf-systems): New function. + +2007-01-12 Marco Baringer mb@bese.it + + * slime.el (slime-keys): Remove binding of M-*, restore binding of + M-,. + +2007-01-11 Edi Weitz edi@agharta.de + + * slime.el (slime-repl-test-system, slime-repl-test/force-system): + New REPL shortcuts. Patch by Kevin Rosenberg + kevin@rosenberg.net. + +2007-01-11 Juho Snellman jsnell@iki.fi + + * slime.el (slime-read-expression-map): restore tab completion in + the minibuffer. Switch the slime-mode-map and minibuffer-local-map + around, so that the minibuffer binding for return takes precedence + over the slime-mode one. + +2007-01-11 Marco Baringer mb@bese.it + + * swank.lisp (inspect-for-emacs integer): Don't die if the integer + can't be expressed as a float. Patch by Ariel Badichi + abadichi@bezeqint.net. + + * slime.el (slime-keys): Removed binding of M-, + +2007-01-11 Helmut Eller heller@common-lisp.net + + * slime.el: Some cleanups for the debugger code: add some outline + sections and docstrings. + + (sldb-setup): Always display the beginning of the condition + text. Previously, we always showed the beginning of the backtrace. + + (sldb-prune-initial-frames): Do what the docstring says. Reverted + to Luke's version. + + (sldb-dispatch-extras): Fix typo. + + (sldb-insert-restarts, sldb-insert-frames) + (sldb-insert-frame, sldb-fetch-more-frames) + (sldb-toggle-details, sldb-show-frame-details) + (sldb-insert-locals): Simplified. + (sldb-frame-details): New. + + (slime-save-coordinates, slime-coordinates) + (slime-restore-coordinate, slime-count-lines): New macro and its + helpers. + (sldb-recenter-region): Renamed from slime-maybe-recenter-region. + + (sldb-enable-styled-backtrace, sldb-show-catch-tags) + (sldb-highlight): Deleted. Seem to be obsolete. + (sldb-add-face): Removed, because it is now the same as + slime-add-face. + + (sldb-help-summary): Deleted. The docstring for sldb-mode is + already pretty terse. + (define-sldb-face): Renamed from def-sldb-face. + + * swank-sbcl.lisp, swank-cmucl.lisp (condition-extras): Fix typo + +2007-01-10 Helmut Eller heller@common-lisp.net + + * swank.lisp (*sldb-printer-bindings*): Add *print-right-margin*. + (debug-in-emacs): Bind *sldb-printer-bindings* here ... + (backtrace, debugger-info-for-emacs, frame-locals-for-emacs): + ... and remove redundant bindings here. + +2007-01-10 Attila Lendvai attila.lendvai@gmail.com + + * slime.el: FIX: set-keymap-parents for GNU Emacs was bogus, fixed + by Ariel Badichi. + +2007-01-09 Helmut Eller heller@common-lisp.net + + * slime.el (slime-repl-merge-histories): Use (setf (gethash ...) + instead of puthash, for Emacs 20. + +2007-01-09 Juho Snellman jsnell@iki.fi + + SBCL 1.0.1.15 supports restart-frame natively, and uses a different + debug catch tag interface than earlier versions. + + * swank-sbcl (sbcl-with-restart-frame): New function, detects SBCL + 1.0.1.15 or later. + (return-from-frame): Another version for 1.0.1.15, using + sb-debug:unwind-to-frame-and-call + (restart-frame): Another version for 1.0.1.15, using + sb-debug:unwind-to-frame-and-call + +2007-01-07 Helmut Eller heller@common-lisp.net + + * swank.lisp (open-streams): Don't pass nil to make-fn-streams; + use a dummy function as workaround. Both arguments must be + functions and CMUCL checks the types. + +2007-01-06 Attila Lendvai attila.lendvai@gmail.com + + * slime.el: Added set-keymap-parents when not available (GNU + Emacs). Result: slime bindings while reading expressions from the + minibuffer. + + * slime.el, swank.lisp: FIX: slime-insert-possibly-as-rectange and + sldb stuff on newer emacsen + +2007-01-04 Attila Lendvai attila.lendvai@gmail.com + + * slime.el: Added slime-insert-possibly-as-rectangle and use it + when inserting things here and there. The effect of this is that + multi-line strings coming from swank (e.g. stuff in sldb) are + inserted with insert-rectangle, so they are properly indented. + + * swank.lisp: FIX: sort is destructive, call copy-seq at a few + places. FIX: bind *sldb-printer-bindings* also in + frame-locals-for-emacs. + +2007-01-03 Attila Lendvai attila.lendvai@gmail.com + + * swank.lisp: FIX: drop extra "Slots: " from standard-object's + inspector presentation + + * swank.lisp: FIX: keyword symbols keep their : when travelling + from swank to slime + + * slime.el: FIX: older Emacsen have no line-number-at-pos. + + * slime.el: Convert some minibuffer reading defun's to defun* and + use keywords. Support extra arguments. + + * slime.el: Use set-parent-keymaps when available (xemacs only for + now) when setting up slime-read-expression-map. The effect of this + is that the minibuffer will have all the slime-mode-map keys where + minibuffer-local-map is not overriding. + + * slime.el, swank.lisp: Handle better the case when swank can not + read anything from the string sent to be inspected. Only bring up + the debugger when the inspect command is prefixed. + +2006-12-31 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Restore the nested-presentations feature. + + * present.lisp (slime-stream-p): Allow sending presentations to + the repl-results stream. + (make-presentations-result): Removed. + (send-repl-results-to-emacs): New. + + * swank.lisp (connection): New slot repl-results (a stream). + (make-output-function-for-target): New. + (open-streams): Use it here to also create a stream for REPL results. + (initialize-streams-for-connection): Store the stream. + +2006-12-29 Edi Weitz edi@agharta.de + + * slime.el (slime-find-asd, slime-read-system-name): Only offer + initial input if system is really in central registry. + +2006-12-29 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Simplify the REPL-results protocol. The results are now printed + using special :WRITE-STRING events from the Lisp side. + + * slime.el (slime-repl-insert-prompt): Don't insert a result, only + the prompt. + (slime-repl-insert-result): Removed. + (slime-repl-eval-string, slime-repl-show-abort) + (slime-repl-set-package, slime-output-buffer) + (slime-repl-update-banner): Change all callers. + (slime-dispatch-event): Event :WRITE-STRING gets an + optional argument TARGET, which controls where the string is + inserted. + (slime-write-string): Handle targets NIL (regular process output) + and :REPL-RESULT. + + * swank.lisp (make-presentations-result): Removed. + (send-repl-results-to-emacs): New function, sends :WRITE-STRING events. + (listener-eval): Use it here instead of make-presentations-result. + +2006-12-28 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Performance improvement for slime-autodoc-mode, in particular when + there are REPL results that are long lists. + + * slime.el (slime-repl-mode-beginning-of-defun) + (slime-repl-mode-end-of-defun): New. + (slime-repl-mode): Use them as beginning-of-defun-function and + end-of-defun-function. + (slime-enclosing-operator-names): Bind + parse-sexp-lookup-properties to nil, don't parse more than 20000 + characters before point, don't determine exact argument positions + larger than 64. Byte-compile this function. + +2006-12-24 Attila Lendvai attila.lendvai@gmail.com + + * slime.el, swank.lisp: Added customizable dwim lookup hook + support for inspect + + * doc/slime.texi: Small doc fixes by Alfredo Beaumont + + * swank.lisp: Change the order to [set value] [make unbound]. Sort + slot names in the inspector + +2006-12-23 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * swank-clisp.lisp (make-weak-key-hash-table) + (make-weak-value-hash-table): Implement for CLISP, so that the + REPL results history does not cause "memory leaks". + + * slime.el (slime-inspect): Add a dwim-mode keyword argument, move + all input handling into the interactive spec. Restore the + behavior of slime-inspect when point is within a presentation (no + prompting, no DWIM). + (slime-inspect-presentation-at-mouse): Don't do DWIM here, so the + presentation-retrieval expression does not end up on the inspector + stack. + (slime-inspector-position): New. + (slime-inspector-operate-on-point, slime-inspector-reinspect): Use + it here to make it work on GNU Emacs too. + (slime-open-inspector): Fix row-col addressing at end of buffer. + +2006-12-20 Attila Lendvai attila.lendvai@gmail.com + + * slime.el: FIX: inspecting presentations from the right click + menu broke in the inspect refactor + + * slime.el: FIX: slime-fuzzy-target-buffer-completions-mode's + keymap must always precede other keymaps + + * slime.el, swank.lisp: Extend :write-string with and &optional + presentation id and use this in present-in-emacs + + * swank.lisp: Added present-in-emacs that prints a presentation of + the given object in the repl + + * swank.lisp: Return the inspected object when inspecting from the + lisp side. + + * swank.lisp: Turn off right margin for restart printing, too + +2006-12-19 Attila Lendvai attila.lendvai@gmail.com + + * HACKING: Added useful init.el piece into HACKING about + update-change-log + + * swank.lisp: In all-slots-for-inspector pad slot names to be + equal length, so the result is more readable + + * slime.el: Fix slime-insert-presentation to handle multi-line + presentations better (use insert-rectangle) + + * swank.lisp: Properly bind *sldb-printer-bindings* and turn off + right margin while printing stuff in sldb + + * slime.el: Smarten up the sldb heuristic that drops swank frames + + * swank-allegro.lisp, swank-backend.lisp, swank-openmcl.lisp, + swank-sbcl.lisp, swank.lisp: Added hash-table-weakness and use it + in hash-table-inspecting + + * swank.lisp: Hashtable inspecting: added [clear hashtable] + and [remove entry] actions + + * slime.el, swank.lisp: FIX dwim inspecting to handle (setf + some-fun) functions, too + + * slime.el: FIX: slime-sexp-at-point for foo::|bar::baz| + + * slime.el: FIX: Properly keep track of slime-buffer-package in + the inspector + + * swank.lisp: Small: get rid of notes and warnings + + * slime.el, swank.lisp: Added dwim-mode to slime-inspect that + tries to be smart unless prefixed + + * slime.el: Make slime-fuzzy-complete-symbol the default in the + belife that it's better for new users + + * swank.lisp: Add (expt 1.2 length) higher scores for longer + matches in fuzzy completion. A good example: puts "make-instance" + before "make-string-input-stream" while completing "make-ins" + + * slime.el: Set slime-fuzzy-completion-in-place enabled by default + + * slime.el: Added (cons row col) addressing to + slime-open-inspector, use in slime-inspector-operate-on-point + + * slime.el: FIX: operate the inspector in the debug thread when + started from sldb + + * slime.el: Convert some inspector defuns to defun* and use + keywords. Other minor cleanups. + +2006-12-18 Marco Baringer mb@bese.it + + * slime.el (slime-region-for-defun-at-point): end-of-defun and + beginning-of-defun modify match-data, added a save-match-data to + prevent this from affecting callers of + slime-region-for-defun-at-point. + +2006-12-15 Edi Weitz edi@agharta.de + + * swank-lispworks.lisp (make-weak-key-hash-table): Weak hash + tables for Lispworks. + (make-weak-value-hash-table): Ditto. + +2006-12-14 Helmut Eller heller@common-lisp.net + + * swank.lisp (*sldb-printer-bindings*): *PRINT-LINES* is in + effect only if *PRINT-PRETTY* is non-NIL, so it better to enable + the pretty printer. Suggested by Madhu enometh@meer.net. + + * slime.el (slime-expand-abbreviations-and-complete): Emacs + `choose-completion' (choosing a completion from the *Completions* + buffer) always replaces text upto (point). So the code which + figures out an `unambiguous-completion-length' and places the + point there in `slime-expand-abbreviations-and-complete' causes + problems: the replacement text gets garbled. Get rid of the bogus + `unambiguous-completion-length'. Patch by Madhu enometh@meer.net + + * swank-cmucl.lisp (remove-gc-hooks): The variables + EXT:*GC-NOTIFY-AFTER* and EXT:*NOTIFY-BEFORE* should hold + functions and should be NIL. This affects the function + REMOVE-GC-HOOKS in swank-cmucl.lisp which sets them to + NIL, (should one happen to use it). Set them back to the original + parameters. Patch by Madhu enometh@meer.net + + * slime.el (slime-repl-output-mouseover-face): Fix a pair of extra + parens. Patch by Madhu enometh@meer.net + +2006-12-14 Helmut Eller heller@common-lisp.net + + * slime.el (slime-search-buffer-package): Remove Xemacs special + casing. There's already a compatibility defun for + match-string-no-properties. + +2006-12-13 Attila Lendvai attila.lendvai@gmail.com + + * swank.lisp: FIX: fuzzy completion for M-V-B. Fix by Madhu. + +2006-12-12 Nikodemus Siivola nikodemus@random-state.net + + * swank.lisp (inspect-for-emacs integer): Pad the hex formatted + value to eight digits, "Code-char:" instead of "Corresponding + character:", "Integer-length:" instead of "Length:", + "Universal-time:" instead of "As time". + (inspect-object): Use TYPE-FOR-EMACS instead of TYPE-OF. + (inspect-in-emacs): New function, analogous to ED-IN-EMACS. + + * swank-backend.lisp (type-for-emacs): New generic function, + defaults to TYPE-OF for non-integers, and returns FIXNUM or BIGNUM + for integers. + + * slime.el (destructure-case): Indicate in the error message that + it was the Elisp destructure-case that failed to avoid confusion. + (slime-check-eval-in-emacs-enabled): More verbose error message. + +2006-12-11 Attila Lendvai attila.lendvai@gmail.com + + * swank.lisp: Added [set value] command for slot inspecting + + * slime.el: Work on repl history navigation, restore old M-p/M-n + behaviour due to #lisp demand + + Also print the current regexp in the minibuffer messages. M-p/M-n + takes the repl input up to the point not the entire input as it + did before. + slime-repl-previous/next-input-starting-with-current-input: new + names for the old M-p/M-n commands History navigation commands + jump to the end of buffer when point is before the prompt. + + * slime.el: Fix/smarten up temp-buffer-quit + + Now it tries its best to remember the original window config and + restore it at slime-temp-buffer-quit unless it was changed + meanwhile. IOW, fix "q" after macroexpand in a macroexpand buffer + not closing the temp window. + Also fix the compiler notes usage of the temp buffer. + + * swank-backend.lisp, swank.lisp: + Added inspect-slot-for-emacs to let users customize it. + + Use all-slots-for-inspector everywhere, render link to both the + effective and direct slots when both are available. Dropped + slot-value-using-class-for-inspector and friends. Added + slot-makunbound-using-class to the swank-mop package and added + a [make-unbound] action to the standard slot presentation. + + * slime.el: FIX: slime-symbol-name-at-point for symbols like + foo::|bar::baz| + + * .cvsignore, swank.lisp: FIX: Drop #. and add #, to escaped + symbol chars + + * slime.el: Added slime-repl-delete-from-input-history that + deletes the current history entry when no input is supplied + + * slime.el: slime-repl-kill-input kills the entire input when + point is at the prompt and resets the history navigation state + + * slime.el: + Use a hashtable to remove duplicates in slime-repl-merge-histories + +2006-12-07 Marco Baringer mb@bese.it + + * swank.lisp (init-inspector): Added eval parameter. If NIL we + don't eval FORM but limit our selves to cl:read'ing it and + inspecting that value. + + * slime.el (slime-inspect): If a prefix argument is provided pass + :eval nil to swank:init-inspector. + +2006-12-07 Paul Collins paul@briny.ondioline.org + + * hyperspec.el (common-lisp-hyperspec): Strip all text properties + from the symbol-at-point to avoid problems with read-only text. + +2006-12-06 Marco Baringer mb@bese.it + + * slime.el (slime-search-buffer-package): Don't call + match-string-no-properties if it's not defined (as is on some + xemacs') + (slime-repl-clear-buffer): Added optional prefix argument + specifying how many lines to leave. + +2006-12-06 Johan Bockg�rd bojohan+sf@dd.chalmers.se + + * swank.lisp (fuzzy-completion-set): Don't mix for clauses and + body clauses in loop. + +2006-12-05 Helmut Eller heller@common-lisp.net + + * swank.lisp (create-swank-server): Removed. Use create-server + instead. + + * slime.el (slime-first-change-hook): Don't do anything if buffers + file doesn't exist. + (slime-start, slime-set-connection-info): Add support for a + :init-function which is called after the usual initialization of the + connection is completed. + + * swank-source-file-cache.lisp (buffer-first-change): Always + return nil and remove the now redundant test with probe-file. + + * swank-backend.lisp (guess-external-format): Return nil if the + file can't be opened. Previusly we wrongly read from stdin. + +2006-12-05 Juho Snellman jsnell@iki.fi + + Real xref support for SBCL (requires SBCL 1.0.0.18). + + * swank-sbcl.lisp (who-calls): New function, fetch xref data from + sb-introspect. + (who-binds): Ditto. + (who-sets): Ditto. + (who-references): Ditto. + (who-macroexpands): Ditto. + (defxref): New macro, create the above functions. + (source-location-for-xref-data): New, map from sb-introspect xref + format to the Swank xref format. + (sanitize-xrefs): Map PCL method names to something more readable. + (string-path-snippet): New function, finds a more accurate source + snippet for definition source locations which have both an + :emacs-string and a full source path available. Otherwise the xref + location would point to the toplevel form rather than the exact + form for functions compiled with C-c C-c. + (source-file-position): New function, somewhat like + source-path-file-position but uses the source-file cache, handles + missing form-paths more gracefully. + (make-definition-source-location): Use the above two functions. + (sbcl-with-xref-p): New function, detect whether SBCL has xref support + for backwards compability. + +2006-11-26 Juho Snellman jsnell@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@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@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@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@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@common-lisp.net + + * slime.el (slime-edit-definition): Don't hide error messages. + +2006-11-21 Helmut Eller heller@common-lisp.net + + * swank.lisp (*coding-system*): "Coding systems" are now strings + instead of keywords. + +2006-11-19 Helmut Eller heller@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@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@agharta.de + + * slime.el (slime-fuzzy-completion-time-limit-in-msec): Escaped + left parenthesis in doc string. + +2006-11-05 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime.el (slime-complete-keywords-contextually): Unused + variable, removed. + +2006-11-05 Helmut Eller heller@common-lisp.net + + * slime.el (sldb-sexp-highlight-mode): Remove bloat. + +2006-11-04 Matthias Koeppe mkoeppe@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@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@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@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@FreeBSD-uk.eu.org). + +2006-10-30 Marco Baringer mb@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@common-lisp.net + + * slime.el (slime-global-variable-name-p): Oops... need to handle + very long strings. + +2006-10-29 Attila Lendvai attila.lendvai@gmail.com + + * slime.el (slime-global-variable-name-p): Use defun* instead of + defun. + +2006-10-29 Helmut Eller heller@common-lisp.net + + * slime.el (slime-global-variable-name-p): Simplified. + +2006-10-28 Matthias Koeppe mkoeppe@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@toshkov.org + + * hyperspec.el: Missing Hyperspec links for ~| and ~~ + +2006-10-27 Ivan Toshkov ivan@toshkov.org + + * hyperspec.el: Missing Hyperspec links for ~% and ~& + +2006-10-27 Nikodemus Siivola nikodemus@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@mail.math.uni-magdeburg.de + + * swank-allegro.lisp (sldb-break-at-start): Implement. + +2006-10-26 Attila Lendvai attila.lendvai@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@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@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@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@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@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@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@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@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@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@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@common-lisp.net + + * slime.el (sldb-activate): Get debug-info from the correct + thread. Fixes bug reported by Dan Weinreb dlw@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@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@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@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@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@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@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@bese.it + + * swank.lisp (*globally-redirect-io*): Change default value to T. + +2006-09-25 Juho Snellman jsnell@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@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@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@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@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@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@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@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@common-lisp.net + + * swank-scl (arglist, function-arglist, spawn): update for the SCL. + +2006-09-13 Brandon Bergren bdragon@mailsnare.net + + * slime.el (slime-filename-translations): Fix docstring + +2006-09-13 Bob Halley halley@play-bow.us + + * swank.lisp (format-iso8601-time): Properly handle non integer + time zones. + +2006-09-13 Taylor R Campbell campbell@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@seas.smu.edu + + * slime.el (slime-repl-disconnect): New repl shortcut. + +2006-09-13 Marco Baringer mb@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@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@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@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@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@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@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@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@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@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@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@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@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@common-lisp.net + + * slime.el (slime-thread-quit): Call swank:quit-thread-browser. + Reported by Taylor R Campbell. + +2006-07-28 Willem Broekema metawilm@gmail.com + + * swank-allegro.lisp: Profiling functions on Allegro (except for + profile-package). + +2006-07-24 Matthias Koeppe mkoeppe@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@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@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@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@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@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@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@common-lisp.net + + * swank-sbcl.lisp (find-definitions): Remove backward + compatibility code. + +2006-06-26 Lu�s Oliveira loliveira@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@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@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@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@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@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@common-lisp.net + + * swank-scl (ext:stream-write-chars): update for SCL 1.3. + +2006-06-09 Alan Ruttenberg alanr-l@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@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@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@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@mumble.net + * swank-abcl: slot-boundp-using-class slot-value-using-class so you + can inspect instances + +2006-05-26 Tobias C. Rittweiler tcr@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@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@mumble.net + * swank-abcl: Add some more mop functions to you can inspect classes, + generic functions, methods, slots. + +2006-05-16 Marco Baringer mb@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@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@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@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@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@common-lisp.net + + * swank.lisp (*use-dedicated-output-stream*): Make it nil by + default to avoid race conditions. + +2006-04-19 Christophe Rhodes csr21@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@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@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@grumblesmurf.org + + * swank-corman.lisp: Define a class file-stream to let swank.lisp + load. + +2005-04-17 Andras Simon andras@renyi.hu + + * swank-abcl.lisp: (accept-connection): New argument: timeout. + +2006-04-14 Gerd Flaig gefla@pond.sub.org + + * slime.el (slime-autodoc): Fix reference to unbound variable. + +2006-04-13 Martin Simmons martin@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@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@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@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@charter.net + + * slime.el (slime-fontify-string): Use set-text-properties, not + propertize, for Emacs 20 compatibility. + +2006-03-30 Helmut Eller heller@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@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@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@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@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@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@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@yahoo.com + + * swank-allegro.lisp (set-default-directory): Fix for pathnames + without a trailing slash. + +2006-03-24 Matthias Koeppe mkoeppe@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@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@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@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@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@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@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@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@hotpop.com + + * swank-allegro.lisp (inspect-for-emacs): Fix typo. + +2006-03-16 Gary King gwking@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@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@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@acceleration.net + + * slime.el (slime-create-filename-translator): use the tramp + methods for dissecting and building filenames. + +2006-03-04 Wojciech Kaczmarek wojtekk@kofeina.net + + * slime.el (slime-filename-translations): Typo in example. + (slime-create-filename-translator): Typo in generated lambdas. + +2006-03-03 Marco Baringer mb@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@mail.math.uni-magdeburg.de + + * slime.el (slime-eval-macroexpand-inplace): Indent the inserted + macroexpansion. + +2006-02-27 Marco Baringer mb@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@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@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@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@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@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@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@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@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@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@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@mail.math.uni-magdeburg.de + + * slime.el (slime-complete-form): Indent the inserted template. + +2006-02-04 Matthias Koeppe mkoeppe@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@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@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@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@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@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@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@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@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@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@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@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@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@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@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@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@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@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@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@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@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@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@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@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@common-lisp.net + + * swank-scl.lisp (accept-connection): handle the :buffering argument. + +2005-11-13 Andras Simon andras@renyi.hu + + * swank-abcl.lisp: (accept-connection): New argument: buffering. + +2005-11-13 Andras Simon andras@renyi.hu + + * swank-abcl.lisp: Steal auto-flush stuff from swank-sbcl.lisp + +2005-11-11 Helmut Eller heller@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@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@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@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@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@renyi.hu + + * swank-abcl.lisp (inspect-for-emacs): Track mop changes in ABCL. + +2005-10-30 Helmut Eller heller@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@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@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@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@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@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@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@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@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@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@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@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@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@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@synap.se + + * swank-scheme48: Removed due to excessive whining. + +2005-09-28 Helmut Eller heller@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@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@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@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@synap.se + + * nregex.lisp: Released into the public domain by Lawrence E. Freil. + +2005-09-19 Helmut Eller heller@common-lisp.net + + * slime.el (slime48): New command. + +2005-09-19 Taylor Campbell campbell@mumble.net + + * swank-scheme48/: New backend. + +2005-09-18 Wolfgang Jenkner wjenkner@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@mail.math.uni-magdeburg.de + + * swank.lisp: Move presentation menu protocol here from present.lisp. + +2005-09-15 Alan Ruttenberg alanr-l@mumble.net + * slime.el (slime-repl-return) don't copy presentation to input if + already in input area. + +2005-09-15 Helmut Eller heller@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@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@mail.math.uni-magdeburg.de + + * slime.el (slime-presentation-expression): Remove handling of + cons presentation-ids. + +2005-09-13 Alan Ruttenberg alanr-l@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@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@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@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@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@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@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@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@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@bese.it + + * swank.lisp (to-string): Handle errors during printing of objects. + +2005-08-30 Alan Ruttenberg alanr-l@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@synap.se + + * present.lisp: Added public domain dedication (OK'd by Alanr and + Matthias on the list). + +2005-08-29 Matthias Koeppe mkoeppe@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@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@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@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@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@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@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@cam.ac.uk + + * swank-sbcl.lisp (method-definitions): present qualifiers (if + any). + +2005-08-23 Taylor R. Campbell campbell@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@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@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@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@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@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@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@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@jenty.by + + * swank-clisp.lisp (fspec-pathname): Use the documentation + function instead of accessing clisp internals. + +2005-08-11 Edi Weitz edi@agharta.de + + * swank.lisp (transpose-lists): Fixed it. + +2005-08-10 Alan Ruttenberg alanr-l@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@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@lispworks.com + + * swank-lispworks.lisp (defadvice compile-file): Return all values + from the real compile-file. + +2005-08-10 Edi Weitz edi@agharta.de + + * swank.lisp (transpose-lists): Replaced with much nicer function + by Helmut Eller. + +2005-08-09 Matthias Koeppe mkoeppe@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@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@mail.math.uni-magdeburg.de + + * slime.el (undo-in-progress): Define for XEmacs compatibility. + Reported by Friedrich Dominicus. + +2005-08-07 Matthias Koeppe mkoeppe@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@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@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@gwi.net + + * swank-sbcl.lisp (swank-compile-string): Restore honoring of + *trap-load-time-warnings*. + +2005-08-03 Juho Snellman jsnell@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@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@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@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@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@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@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@common-lisp.net + + * swank-allegro.lisp (find-external-format): Fix typo. + +2005-07-06 Helmut Eller heller@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@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@users.sourceforge.net + + * swank-clisp (describe-symbol-for-emacs): Report :setf and :type + where appropriate. + +2005-07-03 Helmut Eller heller@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@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@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@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@agharta.de + + * swank.lisp (find-matching-packages): Also use nicknames. + +2005-06-13 Edi Weitz edi@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@comail.ru + + * slime.el (slime-with-xref-buffer): fix "pgk" typo. + +2005-06-12 Christophe Rhodes csr21@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@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@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@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@grumblesmurf.org + + * doc/slime.texi, PROBLEMS: Added notes about CCL. + +2005-06-03 Helmut Eller heller@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@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@users.sourceforge.net + + * swank-clisp (getpid): Updates for current CLISP versions. Use + defimplementation. Define always (slime needs it). + +2005-06-01 Helmut Eller heller@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@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@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@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@mumble.net + + * slime.el text-property-default-nonsticky not defined in + xemacs. oops. + +2005-05-24 Alan Ruttenberg alanr-l@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@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@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@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@mumble.net + * swank.lisp make repl output presentation work even if + present.lisp not loaded + +2005-05-20 Luke Gorrie luke@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@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@mumble.net + + * slime.el slime-presentation-map + +2005-05-20 Luke Gorrie luke@synap.se + + * swank.lisp (clear-repl-results): Fixed unbalanced parens. Thanks + Lawrence Mitchell. + +2005-05-19 Alan Ruttenberg alanr-l@mumble.net + + * slime.el (slime-presentation-command-hook) new function for + nicer behaviour for presentations. + (slime-pre-command-hook) do slime-presentation-command-hook + (slime-post-command-hook) put pre-command-hook back if goes away + (slime-copy-presentation-at-point) mouse-2 copies previous output to point + slime-repl-output-mouseover-face what the old output looks like when the mouse moves over it + default: box around it like on lispm + (slime-repl-insert-prompt) add mouseover face, mouse action. newline after output not propertized. + (slime-property-bounds) adjust for lack of propertized newline + to fix: presentation region behaviour should be attach to generic property like + (:acts-as-token t ) rather than tying to repl-output property + +2005-05-19 Luke Gorrie luke@synap.se + + * swank.lisp (*record-repl-results*): Variable to enable/disable + recording of REPL results. True by default. + (*repl-results*): Renamed from ****. + + * slime.el (slime-property-bounds): Factored out this common part + of slime-repl-grab-old-{input,output}. + (slime-read-object): Avoid inline CL code. + +2005-05-18 Antonio Menezes Leitao aml@gia.ist.utl.pt + + * slime.el (slime-repl-inputed-output-face): new face. + (slime-current-output-id): New variable. + (slime-dispatch-event): Bind slime-current-output-id when + neccessary. + (slime-repl-insert-prompt): Add the neccessary text properties to + the result. + (reify-old-output): New function which makes sure swank sees + (swank::get-**** ...) while the user sees the printed + representation of the object. + (slime-repl-return): When called on a old output (as per the + slime-repl-old-output text property, call + slime-repl-grab-old-output. + (slime-repl-send-input): Added the slime-repl-old-input text + property. + (slime-repl-grab-old-input): Keep the old input's text + properties (unwanted text properties are removed later). + (slime-repl-grab-old-output): New function. + (slime-repl-clear-buffer): Added call to swank::clear-**** + (slime-repl-clear-output): Added call to swank::clear-**** and + bind inhibit-read-only to nil. + (slime-inspect): Call slime-read-object to get the value to + inspect. + (slime-read-object): New function which either reads an object + from the minibuffer or returns the object at point if it has the + slime-repl-old-output text property. + + * swank.lisp (*current-id*, ****): New variables. + (add-****, get-****, clear-last-****, clear-****): New functions + for manipulating the repl history. + (listener-eval): Add * to ****. + +2005-05-12 Alan Ruttenberg alanr-l@mumble.net + + * swank.lisp Add ability to customize behavior of the repl. To do + so, add a function to the list swank::*slime-repl-eval-hooks*. + This function is passed the form typed into the repl. The function + should decide whether it wants to handle evaluation of the + form. If not, call (repl-eval-hook-pass) and the next hook is + tried. Otherwise the values the function returns are used instead + of calling eval. Inside the body of the function you can also + suppress having the repl print the result by calling + (repl-suppress-output) and/or suppress the advancement of the + history variables (*** ** * /// // /) by calling + (repl-suppress-advance-history). + + +2005-05-11 Tim Daly Jr. tim@tenkan.org + + * swank-source-path-parser.lisp (read-and-record-source-map): + Ensure that at least the toplevel form is in the source-map. + +2005-05-11 Helmut Eller heller@common-lisp.net + + * slime.el (slime-remove-old-overlays): Remove overlays in all + slime buffers not only in the current buffer. + (slime-filter-buffers): New helper. + (slime-display-completion-list): Take the completed prefix as + additional argument to initialize completion-base-size. This is + apparently needed to make mouse-selection working. + (slime-maybe-complete-as-filename): Factor for common code in + slime-complete-symbol* and slime-simple-complete-symbol. + +2005-05-06 Alan Ruttenberg alanr-l@mumble.net + + * swank-openmcl.lisp specializer-name didn't handle + structure-class which caused meta-. of methods specialized on + defstruct arguments to fail. + +2005-05-06 Helmut Eller heller@common-lisp.net + + * swank-cmucl.lisp (post-gc-hook): Include the elapsed time and + the size distribution. + +2005-05-05 Edi Weitz edi@agharta.de + + * swank-lispworks.lisp (unmangle-unfun): New function to convert + strange symbols in SETF package to SETF function names. + (signal-undefined-functions): Use it. + +2005-05-04 Edi Weitz edi@agharta.de + + * swank-lispworks.lisp (call-with-compilation-hooks): Provide + better implementation. + (compile-file-and-collect-notes): Advice for COMPILE-FILE so + pathname information for undefined functions can be recorded. + (*within-call-with-compilation-hooks*): New special variable used + by CALL-WITH-COMPILATION-HOOKS. + (*undefined-functions-hash*): New special variable to record + pathname information for undefined functions. + (signal-error-database): Make LOCATION parameter optional, use + FILENAME info from error database if not provided. + (signal-undefined-functions): Make LOCATION parameter optional, + use info from *UNDEFINED-FUNCTIONS-HASH* if not provided. + +2005-05-03 Luke Gorrie luke@synap.se + + * swank.lisp (slime-secret): Removed #+unix conditional, suggested + by Edi Weitz. + +2005-05-02 Mark Wooding mdw@nsict.org + + * swank.lisp: If ~/.slime-secret exists then insist that Emacs + sends the contents (as a password) during initial handshaking. + (announce-server-port): Use :IF-EXISTS :ERROR to prevent bad guys + from slipping a symlink into /tmp and reading what port Lisp is + listening on. + + * slime.el: If ~/.slime-secret exists then send it, as per above. + +2005-05-01 Marco Baringer mb@bese.it + + * slime.el (slime-inspector-reinspect): New function which + reinspects the current object. + (slime-inspector-mode-map): Bind slime-inspector-reinspect to g. + +2005-04-29 Dan Pierson dlp@itasoftware.com + + * slime.el (slime-parse-context): Fix method parsing so that + pressing, say, C-c C-t when point is on a '-' in a symbol name + won't break. + (slime-browser-map): New variable. Add support for the common 'q' + keystroke to quit out of the xref. + (slime-fetch-browsable-xrefs): New function. Remove the (FLET ...) + entries which appear on at least CMUCL. I don't believe you can + actually expand them on any current implementation and they just + mess up the browse tree. Use only the method name when looking + up (METHOD ...) entries on CMUCL. This really shouldn't be here, + but I can't see how to avoid the error thrown by swank:xref. + (slime-expand-xrefs): Use it. + (slime-call-with-browser-setup): Initialize slime-buffer-package + properly. Previously, lisp-mode was called after setting it, but + lisp-mode clears all local variables, use lisp-mode-variables + instead. + + * swank-cmucl.lisp (toggle-trace): Be more carefully when tracing + methods: try both (METHOD ...) and (PCL:FAST-METHOD ...). + +2005-04-27 Helmut Eller heller@common-lisp.net + + * swank-cmucl.lisp (+header-type-symbols+): Drop the third arg to + apropos-list; it's no longer supported in recent CMUCLs. + +2005-04-21 Luke Gorrie luke@synap.se + + * swank.lisp (arglist-to-string): Rolled back the previous change + because it interferred with values appearing in parameter lists. + +2005-04-20 Luke Gorrie luke@synap.se + + * swank.lisp (arglist-to-string): Bind *PRINT-ESCAPE* to NIL. This + way symbols in arglists are printed as with PRINC, i.e. without + package qualifier. + + * swank-sbcl.lisp (preferred-communication-style): Use + `linux_no_threads_p' alien variable to decide whether to use + :SPAWN. From dan_b for compatibility with new SBCLs. + +2005-04-19 Helmut Eller heller@common-lisp.net + + * PROBLEMS: Warn about old kernels. + + * swank-backend.lisp: Fix some typos. + + * swank-sbcl.lisp (preferred-communication-style): Don't test for + sb-futex, it has lost its meaning in 0.8.21. + +2005-04-18 Helmut Eller heller@common-lisp.net + + * slime.el (inferior-lisp-program): Defvar it here, in case it is + not defined in loaddefs and inf-lisp is not loaded. (That's the + case in XEmacs.) + + * mkdist.sh: update version number. + + * doc/slime.texi: Update version numbers for SBCL and ACL. + +2005-04-17 Peter Seibel peter@gigamonkeys.com + + * swank-loader.lisp (*implementation-features*): Added features + for GCL and ECL ... + (lisp-version-string): ... and code to compute version + string. (Supplied by someone who's email I've misplaced.) + +2005-04-14 Helmut Eller heller@common-lisp.net + + * slime.el (slime-selector): Discard input after sleeping. + +2005-04-09 Helmut Eller heller@common-lisp.net + + * slime.el (sldb-get-buffer): Create a fresh buffer if there's no + buffer for the connection (and don't reuse an existing buffer even + if it has a matching name). + (slime-buffer-visible-p, slime-ir1-expand): Delete unused + functions. Mark some others as unused, but leave them there + because they are potentially useful. + + * swank.lisp (with-io-redirection, with-connection) + (with-buffer-syntax): Implement macros with `call-with' functions + to avoid some code bloat. + (call-with-connection, maybe-call-with-io-redirection) + (call-with-buffer-syntax): New functions. + (interactive-eval): Use from-string instead of read-from-string to + avoid problems whit *read-suppress*. + + * swank-sbcl.lisp: Add a few comments. + + * swank-abcl.lisp (print-frame): Trim whitespace to make the + backtrace look a bit terser. + +2005-04-07 Helmut Eller heller@common-lisp.net + + * slime.el (slime-net-coding-system): More fixes for + non-mule-XEmacsen. + (slime-net-coding-system): Even more fixes to make it for + mule-XEmacs. + +2005-04-05 Juergen Gmeiner gj@gjdv.at + + * swank-lisworks.lisp (find-top-frame): If we can't find an + invoke-debugger frame we take any old frame at the top. + +2005-04-04 James McIlree ovrskeek@mac.com + + * slime.el (find-coding-system, check-coding-system) + (process-coding-system, set-process-coding-system): Dummy + functions for no-mule-XEmacsen. + +2005-04-04 Helmut Eller heller@common-lisp.net + + * slime.el (slime-repl-show-maximum-output): New + function. Immitate the scrolling behavior of a terminal. + (slime-with-output-end-mark, slime-repl-return) + (slime-repl-send-input, slime-display-output-buffer): Use it + (slime-lisp-implementation-version, slime-machine-instance): New + connection variables. Suggested by Eduardo Mu�oz. + (slime-set-connection-info): Initialize them. + + * swank.lisp (connection-info): Include version and hostname in + the result. + + * swank-cmucl.lisp (breakpoint-values): Fixes for CMUCL-2005-03 + snapshot. + + * doc/slime.texi: Fix spelling errors. + + * cl-indent.el: Remove the file. Let the Emacs developers + maintain it. + +2005-04-01 Helmut Eller heller@common-lisp.net + + * slime.el (sldb-get-buffer): Initialize the buffer local + variables slime-buffer-connection and slime-current-thread when + creating a fresh buffer. + + * swank.lisp (spawn-repl-thread): Use + *default-worker-thread-bindings* just like spawn-worker-thread. + (wrap-sldb-vars): New function. Rebind *sldb-level* to avoid + confusion with recursive errors during eval-in-frame. + (eval-string-in-frame, pprint-eval-string-in-frame): Use it. + + * swank-allegro.lisp (eval-in-frame): Allegro's + eval-form-in-context does nothing special with lexical variables + in the frame. Wrap an explicit LET around the form to get similar + behavior as in the other Lisps. + (inspect-for-emacs (structure-object)): Remove structure related + methods. It's already covered by the general case with + allegro-inspect. + (common-seperated-spec): Deleted + +2005-04-01 Luke Gorrie luke@synap.se + + * slime.el (slime-xref-mode): Summarise the most important + bindings in the mode description. + + * metering.lisp: Now supports only CLISP and OpenMCL. + Removed a lot of really ugly reader-conditionalized code, much of + it for archaic lisps (#+cltl2, #+lcl3.0, #+mcl1.3.2, etc). + + * swank-source-path-parser.lisp (check-source-path): Signal an + error if a source path is malformed. SBCL sometimes gives (NIL). + (source-path-stream-position): Use it. + + * slime.el (slime-goto-definition): Handle :error locations here + before any window/buffer changes are made. + +2005-04-01 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime.el (slime-keys): Bind slime-edit-definition-other-window + to `C-x 4 .' and slime-edit-definition-other-frame to `C-x 5 .', + shadowing the equivalent find-tag... bindings. + (slime-goto-definition): In the other-window and other-frame cases, + make sure point does not move in the originating window, even when + the definition is found in the same buffer. + +2005-03-31 Luke Gorrie luke@synap.se + + * doc/slime.texi (slime-selector): New section. + (Inspector): Updated for the post-1.0 inspector. + + * slime.el (slime-selector): Removed unneeded "the" prefixes in + descriptions of what the selector methods do. + +2005-03-27 Helmut Eller heller@common-lisp.net + + * PROBLEMS, NEWS, doc/slime.texi: Some updates for the upcoming + release. + +2005-03-27 Russell McManus russell_mcmanus@yahoo.com + + * swank-clisp.lisp (getpid): Try sys::process-id if + sys::program-id doesn't exist. + +2005-03-23 Marco Baringer mb@bese.it + + * swank.lisp (commit-edited-value): Read a backquated string, + instead of quating the result of read. This allows one to put + ,(form) into edit-value buffers. + +2005-03-22 Helmut Eller heller@common-lisp.net + + * swank-lispworks.lisp (swank-compile-string): Bind *print-radix* + to t, to avoid problems if somebody uses different values for + *print-base* and *read-base*. Reported by Alain Picard. + (emacs-connected): Add default methods for + environment-display-notifier and environment-display-debugger. + +2005-03-21 Helmut Eller heller@common-lisp.net + + * swank-sbcl.lisp (locate-compiler-note): Handle errors in macros + better. + (source-file-source-location): Read the snippet at the right + position. + + * swank-source-file-cache.lisp (read-snippet): Take the start + position as optional argument. + +2005-03-21 Helmut Eller heller@common-lisp.net + + * swank-sbcl.lisp (quit-lisp): If we are running multithreaded, + terminate all other threads too. (still broken in 0.8.20.27; used + to work in ~0.8.20.2.) + (with-debootstrapping, call-with-debootstrapping): Remove ugly + backward compatibility code. + (sbcl-source-file-p, guess-readtable-for-filename): New utilities. + (function-source-location): Handle work off to helper functions. + (find-function-source-location): New function. Use the + shebang-readtable for SBCL source files. + (function-source-position, function-source-filename) + (function-source-write-date, function-toplevel-form-number) + (function-hint-snippet, function-has-start-location-p) + (function-start-location): New helpers. + (safe-source-location-for-emacs): Don't catch errors if + *debug-definition-finding* is true. + (inspect-for-emacs): Minor beautifications. + + * swank.lisp (commit-edited-value): Use buffer syntax. + (compile-file-for-emacs, compile-string-for-emacs): Bind + *compile-print* to nil. + + * swank-cmucl.lisp (call-with-debugging-environment): Rebind + kernel:*current-level* 0. Useful for debugging pretty printer + code. + (inspect-for-emacs): Show details of interpreted functions. + +2005-03-21 Luke Gorrie luke@synap.se + + * swank-sbcl.lisp (function-source-location): For definitions + compiled in Emacs buffers, include the :emacs-string as a :snippet + hint for search-based M-. lookup. + +2005-03-21 Edi Weitz edi@agharta.de + + * swank-loader-lisp (*implementation-features*, *os-features*, + *architecture-features*): LispWorks was completely missing. + +2005-03-18 Luke Gorrie luke@synap.se + + * slime.el (slime-complete-symbol*-fancy): Now nil by default. + +2005-03-18 Helmut Eller heller@common-lisp.net + + * swank-source-path-parser.lisp (make-source-recording-readtable): + Ignore non-ascii chars. + + * swank-sbcl.lisp (swank-compile-string): Re-implemented. This + time with temp-files and proper source-location tracking. + (install-debug-source-patch, debug-source-for-info-advice): Patch + SBCL's debug-source-for-info so that we can dump our own bits of + debug info. + (function-source-location, code-location-source-path): Rewritten + to handle C-c C-c functions. Also use the source-path to locate + the position. + (locate-compiler-note): Renamed from resolve-note-location. + (temp-file-name, call/temp-file): New utilities. + (file-source-location, lisp-source-location) + (temp-file-source-location, source-file-source-location) + (string-source-position, code-location-debug-source-info) + (code-location-debug-source-name, code-location-debug-source-created,) + (code-location-debug-fun-fun, code-location-from-emacs-buffer-p) + (function-from-emacs-buffer-p, function-debug-source-info) + (info-from-emacs-buffer-p, code-location-has-debug-block-info-p) + (stream-source-position): Lots of new helper functions. + (with-debootstrapping): Moved upwards so that it can be used for + source location searching. + (source-location-for-emacs): Deleted + +2005-03-16 Helmut Eller heller@common-lisp.net + + * slime/swank.lisp (*macroexpand-printer-bindings*): New user + variable. + (apply-macro-expander): Use it. + (call-with-bindings): Bind variables in reverse order. Thit makes + it easer to cons or push a new binding at the front the list. + (with-bindings): New macro. + + * slime.el (slime-run-when-idle): New function to hide + Emacs/XEmacs differences. + (slime-process-available-input): Use it. + + * swank-loader.lisp (unique-directory-name): Rewritten to avoid + the rather irritating warning that (warn "Don't know ...") is + unreachable. + +2005-03-13 Luke Gorrie luke@synap.se + + * slime.el (slime-dispatch-event): Use `slime-busy-p' to control + the "; pipelined request" message. This way it takes requests + blocked in the debugger into account and avoids spurious messages. + + * swank.lisp (inspect-for-emacs symbol): Add an "unintern it" + action for symbols. + + * swank-source-file-cache.lisp (read-snippet): Skip comments and + whitespace in SBCL. The source-positions reported by SBCL are not + adjusted to skip over whitespace before the definition. + + * swank-sbcl.lisp (function-source-location): Updated for revised + sb-introspect patch: + s/DEFINITION-SOURCE-CREATED/DEFINITION-SOURCE-WRITE-DATE/ + + * swank-loader.lisp (*os-features*): Added :mswindows. Thanks Will + Glozer. + +2005-03-12 Luke Gorrie luke@synap.se + + * slime.el (slime-edit-value): New function on `C-c E'. Prompts + for a Lisp expression, evaluates and displays the result in a new + buffer for editing, and then setf's the edited value in Lisp after + you press C-c C-c. Usage example: `C-c E asdf:*central-registry*' + Minor docstring and pull-down-menu changes. + + * swank.lisp (value-for-editing, commit-edited-value): New + functions for slime-edit-value. + + * swank-allegro.lisp (toggle-trace): Fix from Antonio Menezes + Leitao. + + * swank-sbcl.lisp: Use swank-source-file-cache to find snippets of + definitions. M-. is now much more robust to modifications in the + source file. + NOTE: To be effective requires a patch to sb-introspect that I + have posted to sbcl-devel. + + * swank-source-file-cache.lisp: Factored this into its own file, + from swank-cmucl.lisp. + + * swank-loader.lisp, swank-cmucl.lisp: Updated for the above. + +2005-03-10 Antonio Menezes Leitao aml@gia.ist.utl.pt + + * slime.el (slime-toggle-trace-fdefinition): If there is no symbol + at point then prompt for one. + +2005-03-09 Peter Seibel peter@gigamonkeys.com + + * swank-loader.lisp (*architecture-features*): Added :pc386 for CLISP. + (unique-directory-name): Change ERROR to WARN. + + * slime.el (slime-register-lisp-implementation): Add facility for + registering lisp implementations with symbolic names that can be + passed to C-u M-x slime. + +2005-03-08 Peter Seibel peter@gigamonkeys.com + + * doc/Makefile (clean): added clean and really_clean targets. + (all): and added slime.pdf to all prerequisites. + + * swank-loader.lisp (*implementation-features*): Whoops. Forgot + CLISP. + (*architecture-features*): Added :x86-64 for SBCL on AMD64 (thanks + Vincent Arkesteijn) + +2005-03-07 Peter Seibel peter@gigamonkeys.com + + * swank-loader.lisp (unique-directory-name): Replaced *lisp-name* + variable with more sophisticated version that accounts for impl, + impl version, os, and hardware architecture. + +2005-03-07 Edi Weitz edi@agharta.de + + * swank.lisp: Fixed parenthesis-balancing problem. + +2005-03-06 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime.el (slime-easy-menu): Add menu item for + slime-complete-form. + + * swank.lisp (format-arglist-for-echo-area): Use extra-keywords to + enrich the list of keywords. + (arglist-to-string): Remove extraneous whitespace. + (keyword-arg, optional-arg): New structures. + (decode-keyword-arg, decode-optional-arg): Return structure + objects rather than multiple values. + (encode-keyword-arg, encode-optional-arg, encode-arglist): New + functions. + (arglist): New slot key-p. + (decode-arglist): Handle &whole, &environment. Store more + information on optional and keyword args, set arglist.key-p. + (values-equal?): Removed. + (print-decoded-arglist-as-template): If keyword is + not a keyword symbol, quote it in the template. + (extra-keywords): Return a secondary value (allow-other-keys). + For make-instance, try to finalize the class if it is not + finalized yet (fix for Allegro CL 6.2). If class is not + finalizable, use direct slots instead of slots and indicate that + the keywords are not complete. + (enrich-decoded-arglist-with-extra-keywords): New function, use + the secondary value of extra-keywords. + (arglist-for-insertion, complete-form): Use it here. + (remove-keywords-alist): New variable. + (remove-actual-args): When the keyword :test is provided, don't + suggest :test-not and vice versa. + + * swank-backend.lisp (:swank-mop package): Export + finalize-inheritance. + +2005-03-06 Luke Gorrie luke@synap.se + + * swank.lisp: Export *LOG-OUTPUT*. + +2005-03-05 Helmut Eller heller@common-lisp.net + + * slime.el (slime-net-sentinel): Always print a message when the + lisp disconnects. + (slime-inferior-lisp): Don't display the buffer. Let callers do + that. + (slime): Display the inferior buffer here. + (slime-quit-lisp, slime-quit-sentinel): Use set a special sentinel + and do most of the cleanups there. + (slime-repl-sayoonara): Use slime-quit-lisp. + (slime-restart-inferior-lisp, slime-restart-inferior-lisp-aux) + (slime-restart-sentinel): Use a special sentinel to restart + processes. + (slime-hide-inferior-lisp-buffer): Do the windows arrangement a + bit differently. Related to restart-lisp. + (slime-repl-buffer): Take the connection as second optional + argument. Useful for rearranging windows for dead processes. + + * swank-allegro.lisp (call-with-debugging-environment) + (find-topframe): Hide the first 2 frames. Those are created + by swank-internal functions. + +2005-03-04 Antonio Menezes Leitao aml@gia.ist.utl.pt + + * swank-allegro.lisp (process-fspec-for-allegro, toggle-trace): + Handle setf functions. + (tracedp): Fix free variable. + + * slime.el (slime-trace-query): The :defgeneric query was bogus. + (slime-extract-context): Don't skip over the method name if we are + already at the end of the name. + +2005-03-03 Nikodemus Siivola tsiivola@cc.hut.fi + + * swank-sbcl.lisp: Fixed for latest SBCL HEAD revision and + temporarily backwards-compatible with the current release. + +2005-03-02 Marco Baringer mb@bese.it + + * swank-loader.lisp Look for a file in the same directory as + swank-loader.lisp called site-init.lisp. If it exists we load that + instead of attempting to load ~/.swank.lisp. + (user-init-file): Superseded by load-user-init-file. + (load-user-init-file): New function. + (load-site-init-file): New function. + +2005-03-01 Helmut Eller heller@common-lisp.net + + * slime.el (slime-who-bindings): Bind who-specializes to C-c W a. + (slime-extract-context): Renamed from name-context-at-point. + (slime-beginning-of-list): Renamed from out-first. + (slime-slime-parse-toplevel-form): Renamed from definition-name. + (slime-arglist-specializers): Renamed from parameter-specializers. + (slime-toggle-trace-function, slime-toggle-trace-defgeneric) + (slime-toggle-trace-defmethod, slime-toggle-trace-maybe-wherein) + (slime-toggle-trace-within): Deleted. Everything is now handled + by slime-trace-query. + (slime-calls-who): For symmetry with silme-who-calls. + (slime-edit-definition-with-etags): Better intergration with TAGS. + (slime-edit-definition-fallback-function): Mention it in the + docstring. + + * swank-backend (calls-who, toggle-trace): New functions. + (toggle-trace-function, toggle-trace-generic-function-methods, + (toggle-trace-method, toggle-trace-fdefinition-wherein): Replaced + by toggle-trace. + + * swank.lisp (*sldb-printer-bindings*, *swank-pprint-bindings*): + New variables. The alists replace the variables which where + previously hidden with the define-printer-variables macro. + (define-printer-variables, with-printer-settings): Deleted, + because the variable names where not visible in the source code. + (swank-toggle-trace): Renamed from toggle-trace-fdefinition. + + * swank-cmucl.lisp, swank-lispworks, swank-sbcl.lisp, + swank-allegro.lisp (toggle-trace): Update tracing code for new + interface. + +2005-02-24 Helmut Eller heller@common-lisp.net + + * slime.el (slime-dispatch-event): Add :eval-no-wait and :eval + events. + (slime-eval-for-lisp): New function. + (sldb-buffers): Delete the variable. Use buffer-list instead. + + * swank.lisp: (eval-for-emacs): Use the new backend function + call-with-debugger-hook. + (eval-in-emacs): Cleaned up. Add support for synchronous RPCs. + (receive-eval-result): New function. + (dispatch-event, read-from-socket-io, send-to-socket-io): New + :eval event. Rename :%apply to :eval-no-wait. + (read-user-input-from-emacs, evaluate-in-emacs): Increment + *read-input-catch-tag* instead of re-binding it. Reduces the + danger of throwing to the wrong tag a bit. + + * swank-backend.lisp (call-with-debugger-hook): New function. + Useful if the backend needs special incantations for BREAK. + (toggle-trace-function): Add a default implementation for simple + symbols. + + * swank-lispworks.lisp (slime-env): New class. + (call-with-debugger-hook): Use env:with-environment to pop up our + debugger on a BREAK. + (toggle-trace-method, parse-fspec, tracedp, toggle-trace): + Implement method tracing. + + * swank-sbcl.lisp (call-with-debugger-hook): Bind + sb-ext:*invoke-debugger-hook* instead of setting it in + emacs-connected. + (emacs-connected): Deleted. + + * swank-loader.lisp (compile-files-if-needed-serially): Reduce + verbosity by setting the :print argument for compile-file to nil. + +2005-02-23 Helmut Eller heller@common-lisp.net + + * slime.el (slime-startup-animation, slime-repl-update-banner): + Put the animation back in to keep the kids quiet. + (slime-kill-without-query-p): Change default to nil. + (slime-eval-describe, slime-eval-region) + (slime-pprint-eval-last-expression): Fix typos in docstrings. + (slime-eval/compile-defun-dwim): Deleted. We never had a key + binding anyway. + +2005-02-22 Helmut Eller heller@common-lisp.net + + * slime.el (slime-complete-form): Emacs 20 compatibility fix. + (slime-repl-update-banner): Remove animation stuff. + (slime-startup-animation): Deleted. + + * swank-lispworks.lisp (compute-applicable-methods-using-classes): + Implement it. + +2005-02-20 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Supersede the command slime-insert-arglist with the new command + slime-complete-form and bind it to C-c C-s. 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 make-instance. Examples: + + (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 initialize-instance :after ((object foo) &key blub)) + (make-instance 'foo <C-c C-s> + --inserts--> :bar bar :blub blub initargs...) + + * swank.lisp (arglist): New struct for storing decoded arglists. + (decode-arglist): New function. + (arglist-keywords, methods-keywords, generic-function-keywords, + applicable-methods-keywords): New functions. + (decoded-arglist-to-template-string, + print-decoded-arglist-as-template): New functions. + (arglist-to-template-string): Rewrite using above functions. + (remove-actual-args): New function. + (complete-form): New slimefun. + + * swank.lisp (extra-keywords): New generic function. + + * swank-backend.lisp (:swank-mop package): + Export compute-applicable-methods-using-classes. + + * swank.lisp (arglist-for-insertion): Use extra-keywords to + enrich the list of keywords. + + * swank.lisp (valid-operator-symbol-p): New function. + (valid-operator-name-p): Use valid-operator-symbol-p. + + * slime.el (slime-complete-form): New command. + (slime-keys): Bind C-c C-s to slime-complete-form rather than + slime-insert-arglist. + +2005-02-18 Antonio Menezes Leitao aml@gia.ist.utl.pt + + Improve the trace mechanism (on lisps that support it). SLIME is + now able to trace/untrace flet/labels functions, methods and, of + course, regular and generic functions. + + In the process support for sending code to emacs form the lisp was + added. The code, elisp forms, is sent over the wire like normal + lisp code, evaluated in emacs and the return value is returned + back to the lisp. + + * slime.el (slime-dispatch-event): Added the :evaluale-in-emacs + dispatch state which simply parses the message and class + evaluate-in-emacs. + (evaluate-in-emacs): New function. + (complete-name-context-at-point, name-context-at-point, out-first, + definition-name, parameter-specializers, + slime-toggle-trace-fdefinition, slime-toggle-trace-function, + slime-toggle-trace-defgeneric, slime-toggle-trace-defmethod, + slime-toggle-trace-maybe-wherein, slime-toggle-trace-within): New + functions implementing the new intelligent slime trace. + + * swank-backend.lisp (toggle-trace-function, + toggle-trace-generic-function-methods, toggle-trace-method, + toggle-trace-fdefinition-wherein, + toggle-trace-fdefinition-within): New backend functions + for the new trace facility. + + * swank.lisp (dispatch-event): Handle the :evaluate-in-emacs + message type. + (evaluate-in-emacs): New function. + + * swank-allegro.lisp (toggle-trace-generic-function-methods, + toggle-trace, toggle-trace-function, toggle-trace-method, + toggle-trace-fdefinition-wherein, + toggle-trace-fdefinition-within): Implement. + (process-fspec-for-allegro): New function. + + * swank-cmucl.lisp (toggle-trace-generic-function-methods, + toggle-trace-function, toggle-trace-method, + toggle-trace-fdefinition-wherein): Implement. + (toggle-trace, process-fspec): New functions. + + * swank-sbcl.lisp (toggle-trace-generic-function-methods, + toggle-trace-function, toggle-trace-method, + toggle-trace-fdefinition-wherein): Implement. + (toggle-trace, process-fspec): New functions. + +2005-02-02 Helmut Eller heller@common-lisp.net + + * slime.el: Require the timer package explicitly. + +2005-02-02 Luke Gorrie luke@synap.se + + * slime.el (slime-repl-send-input): Move some properties + of old REPL input (e.g. read-only) from text properties into an + overlay, so that kill/yank will leave them behind. Left + `slime-repl-old-input' as a text properties because it's more + convenient to lookup that way. + (slime-repl-return): Ignore `slime-repl-old-input' property if the + point is in front of the current REPL prompt, i.e. if the user has + copy&pasted some old REPL input into the current input area. + +2005-01-30 Bryan O'Connor bryan-slime@lunch.org + + * slime.el (slime-goto-location-position): Changed the regexp to + require the function-name to be followed by a + non-symbol-constituent character \S_. Previously, a function-name + of "find" first matched find-if-not if it occured earlier in the + file. + +2005-01-27 Helmut Eller heller@common-lisp.net + + * slime.el (slime-busy-p): Ignore debugged continuations to enable + arglist lookup while debugging. Suggested by Lynn Quam. + (sldb-continuations): New buffer local variable in sldb buffers to + keep track of debugged continuations. + (sldb-debugged-continuations): New function. + (sldb-buffers): Renamed from sldb-remove-killed-buffers. + (slime-eval-print): New function to insert the stream output and + the result of an evaluation in the current buffer. + (slime-eval-print-last-expression): Use it. + (slime-interactive-eval): Use slime-eval-print when a prefix + argument was given. + + * swank.lisp (*pending-continuations*, eval-in-emacs) + (debugger-info-for-emacs): Keep track of debugged continuation the + new variable *pending-continuations* and include the list of + active continuations in the debugger info for Emacs. + (eval-and-grab-output): New function. Used by slime-eval-print. + (*log-output*): Renamed from *log-io*. Use *standard-error* as + initial value instead of *terminal-io*. CMUCL opens its own tty + and that makes it hard to redirect to output with a shell. + *standard-error* writes its output to file descriptor 2. + (*canonical-package-nicknames*): Fix typo. + +2005-01-20 Helmut Eller heller@common-lisp.net + + * swank.lisp (parse-symbol): Don't break if the package doesn't + exist. Reported by Lynn Quam. + +2005-01-20 Ian Eslick eslick@csail.mit.edu + + * swank-allegro.lisp (restart-frame): Handle frames with arguments + better. + +2005-01-20 Edi Weitz edi@agharta.de + + * swank-allegro.lisp (handle-undefined-functions-warning): Prevent + breakage if the undefined function is called at multiple + locations. + +2005-01-19 Helmut Eller heller@common-lisp.net + + * swank-gray.lisp (stream-unread-char): If the char argument + doesn't match the contents in the buffer, ignore it and emit a + warning instead. + +2005-01-19 Utz-Uwe Haus haus+slime@merkur.math.uni-magdeburg.de + + * swank-cmucl.lisp (breakpoint): Add a slot for return values to + make return values inspectable in the debugger. + (signal-breakpoint): Initialize the new slot. + +2005-01-19 Matthias Koeppe mkoeppe@merkur.math.uni-magdeburg.de + + * slime.el (slime-insert-arglist): Inserts a template for a + function call instead of the plain arglist; this makes a + difference for functions with optional and keyword arguments. + + * swank.lisp (arglist-to-template-string): New function. + (arglist-for-insertion): Use it + (decode-keyword-arg, decode-optional-arg): New functions. + +2005-01-19 Lars Magne Ingebrigtsen larsi@gnus.org + + * slime.el (slime-header-line-p): Customize variable to + enable/disable the header-line in the REPL. + +2005-01-18 Luke Gorrie luke@synap.se + + * slime.el (slime-complete-symbol*-fancy): New variable to enable + extra bells and whistles with slime-complete-symbol*. Currently + controls whether to use arglists semantically. Default is t. + (slime-complete-symbol*-fancy-bit): Factored out this function. + Only do "semantic" completion when the symbol is in + function-position, avoid interning argument names in Emacs, and + don't display arglists if the minibuffer is active. + +2005-01-14 Luke Gorrie luke@synap.se + + * slime.el (slime-repl-send-input): Make old input read-only using + an overlay instead of a text property. This way if you copy&paste + the input elsewhere it will become editable (overlay is associated + with the buffer region and not the text). + +2005-01-14 Edi Weitz edi@agharta.de + + * slime.el (slime-complete-symbol*): Maybe insert closing + parenthesis or space (depending on arglist) after symbol + completion has finished. Optionally also show arglist. + +2005-01-13 Helmut Eller heller@common-lisp.net + + * swank-cmucl.lisp (create-socket): The byte-order of the :host + argument for CREATE-INET-LISTENER was changed in the Jan 2005 + snapshot. Test whether the symbol 'ext:socket-error exists to + decide if we are in a older version. + (resolve-hostname): Return the address in host byte-order. + +2005-01-12 Robert Lehr bozzio@the-lehrs.com + + * slime.el (slime-changelog-date): Return nil if the ChangLog file + doesn't exits. + (slime-repl-update-banner): Write "ChangeLog file not found" if + the ChangeLog doesn't exist. + +2005-01-12 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime.el (slime-inspector-operate-on-click): New command for + inspecting the value value at the clicked-at position or invoking + an inspector action. + (slime-inspector-mode-map): Bind it to mouse-2. + (slime-inspector-insert-ispec): Add mouse-face properties for + clickable values and action buttons. + +2005-01-12 Helmut Eller heller@common-lisp.net + + * swank.lisp (*default-worker-thread-bindings*): New variable to + initialize dynamic variables in worker threads. + (spawn-worker-thread, call-with-bindings): New helper functions. + (thread-for-evaluation): Use them. + +2005-01-10 Utz-Uwe Haus haus+slime@merkur.math.uni-magdeburg.de + + * swank-sbcl.lisp (profile-package): Add implementation for SBCL. + +2005-01-10 Eduardo Mu�oz emufer@terra.es + + * swank.lisp (inspect-for-emacs-list): LispWorks has a low args + limit for apply: use reduce instead of apply. + +2005-01-10 Helmut Eller heller@common-lisp.net + + * slime.el (slime-conservative-indentation): The default is now + nil. Suggested by Travis Cross. + +2005-01-10 Matthias Koeppe mkoeppe@merkur.math.uni-magdeburg.de + + * slime.el (slime-inspector-next-inspectable-object): Accept a + prefix argument and make wrapping around more reliable. The code + is adapted from `widget-move'. + (slime-inspector-previous-inspectable-object): New command. + (slime-inspector-mode-map): Bind to S-TAB. + +2004-12-16 Martin Simmons martin@xanalys.com + + * swank-lispworks.lisp (create-socket): Work around bug in + comm::create-tcp-socket-for-service on Mac OS LW 4.3. + +2004-12-16 Edi Weitz edi@agharta.de + + * slime.el (slime-complete-symbol*): Bind + comint-completion-addsuffix so unambiguous or exact completion + closes the string automatically. + +2004-12-16 Matthias Koeppe mkoeppe@merkur.math.uni-magdeburg.de + + * slime.el (slime-keys): Bind M-* to + slime-pop-find-definition-stack for compatibility with standard + Emacs conventions. + +2004-12-16 Helmut Eller heller@common-lisp.net + + * swank-source-path-parser.lisp (read-source-form): New function + which uses *read-suppress* properly. Common code from + source-path-stream-position and form-number-stream-position. + (source-path-stream-position): Use it. + + * swank-cmucl.lisp (form-number-stream-position): Use + read-source-form. + + * swank.lisp (frame-for-emacs): Print the frame number a little + nicer with ~2D. + +2004-12-15 Matthias Koeppe mkoeppe@merkur.math.uni-magdeburg.de + + * slime.el (slime-lisp-modes): New variable to make C-c C-k + customizable and usable in scheme-mode. + (slime-compile-file): Use it. + +2004-12-15 Helmut Eller heller@common-lisp.net + + * swank-cmucl.lisp, swank-backend.lisp (frame-package): Delete it. + Include the package name for local variables because it is utterly + confusing if `eval-in-frame' doesn't work due to missing package + prefixes. + + * swank-source-path-parser.lisp (source-path-stream-position): + Bind *read-suppress* to nil before calling + read-and-record-source-map. + + * swank-clisp.lisp (*buffer-name*, *buffer-offset*): Move + definitions upward before the first use. + +2004-12-15 Bryan O'Connor bryan-slime@lunch.org + + * slime.el (slime-edit-definition): Switch to the other frame if + the `where' is 'frame. + (slime-edit-definition-other-frame): New function. + +2004-12-15 Helmut Eller heller@common-lisp.net + + * slime.el (slime-repl-send-input): Make the input read-only to + avoid confusion. + (slime-make-region-read-only): New function. + +2004-12-13 Helmut Eller heller@common-lisp.net + + * slime.el (slime-repl-mode-map): Bind <home> to slime-repl-bol. + Suggested by Chris Capel. + (slime-repl-grab-old-input): Remove the 'old-input text-property + from the copied text. Reported by Tim Oates. + (slime-repl-grab-old-input): Append the old input to the current + input by default. If the new `replace' argument is true, replace + the current input. Suggested by Antonio Menezes Leitao. + (slime-repl-return): Pass the prefix argument to + slime-repl-grab-old-input. + +2004-12-09 Helmut Eller heller@common-lisp.net + + * swank.lisp (*sldb-print-pretty*, *sldb-print-circle*) + (*sldb-print-length*, *sldb-print-level*, *sldb-print-lines*) + (*sldb-print-pprint-dispatch*): Export those symbols. + +2004-12-05 Helmut Eller heller@common-lisp.net + + * slime.el (slime-global-variable-name-p): Also return true for + names of constants like +foo+. Suggested by Christian Lynbech. + + * swank-allegro.lisp (handle-compiler-warning): Handle + undefined-functions warnings by looking the fromat-arguments of + the condition. + (compiler-undefined-functions-called-warning-p) + (location-for-warning, handle-undefined-functions-warning): New + functions. + + * swank-cmucl.lisp (*install-gc-hooks*): New user variable. + (sending-safe-p): New predicate. + (pre-gc-hook, post-gc-hook): Use it. + + * swank.lisp (eval-region): Use a simple loop. + +2004-12-02 Helmut Eller heller@common-lisp.net + + * swank.lisp: (inspect-for-emacs (symbol)): Handle non-interned + symbols. + + * slime.el (slime-repl-clear-buffer, slime-repl-clear-output): Fix + docstrings. + +2004-11-29 Lynn Quam quam@ai.sri.com + + * slime.el (slime-global-variable-name-p): Allow optional + "<package-name>:" or "<package-name>::". + +2004-11-29 Chris Capel pdf23ds@gmail.com + + * swank.lisp (macro-indentation): Ignore &whole, &aux, and + &environment args. + +2004-11-29 Helmut Eller heller@common-lisp.net + + * slime.el (slime-repl-wrap-history): New user variable. + (slime-repl-history-replace): Implement wrap around. + (slime-repl-easy-menu): Fix binding for "Next Input". Reported by + Surendra Singhi. + + * swank-lispworks.lisp (list-callers-internal): Return the + function if dspec:object-dspec returns nil. + (xref-results): Previously, functions for which + dspec:dspec-definition-locations returned nil were ignored. + Include them with a unknown source-location. + + * swank-abcl.lisp, swank-allegro.lisp, swank-clisp.lisp, + swank-cmucl.lisp, swank-openmcl.lisp, swank-sbcl.lisp, + swank-lispworks (accept-connection): The :external-format argument + defaults now to :iso-latin-1-unix. + +2004-11-26 Helmut Eller heller@common-lisp.net + + * swank-cmucl.lisp (read-into-simple-string): Use #-cmu19 instead + of #+cmu18e. + +2004-11-25 Chris Capel pdf23ds@gmail.com + + * slime.el (slime-indent-and-complete-symbol): Echo the arglist if + there's no symbol before point. Don't complete after parens. + (slime-echo-arglist): Factorized from slime-space. + (slime-space): Use it. + (slime-repl-history-replace): Clear the input at the end of the + history. + + * swank.lisp (arglist-to-string): Don't show &whole, &aux and + &environment args. + (clean-arglist): New function. + +2004-11-25 Helmut Eller heller@common-lisp.net + + * slime.el (slime-net-coding-system): Emacs does funky encoding + for `raw-text-unix' use `binary' instead. + (slime-safe-encoding-p): New function. + (slime-net-send): Use it and don't try to send stuff which can't + be decoded by Lisp. + (slime-inferior-lisp-program-history): XEmacs compatibility: + declare it as a variable. + (slime-xref-mode): In Emacs 21, set delayed-mode-hooks to nil + because we don't want to run the lisp-mode-hook. Reported by + Chris Capel. + + * swank.lisp (dispatch-loop): Catch errors and close the + connection. It's almost impossible to run the debugger inside the + control-thread, so let it crash instead. A backtrace would be + nice, though. + (cleanup-connection-threads): Can now be called in the + control-thread. Add a check to avoid thread suicide. + (start-swank-server-in-thread): Fix the call to start-server. + + * swank-sbcl.lisp (%thread-state-slot, %thread-state): Refactored + from thread-status. + (thread-status): Use it. + (all-threads): Exclude zombies. + +2004-11-24 Helmut Eller heller@common-lisp.net + + * slime.el (slime-start-and-load): Use vanilla comint instead of + inf-lisp. Let's try that for a while. + (slime): Ask for the coding system when invoked with C-u C-u. + (slime-net-coding-system, slime-net-valid-coding-systems): Add + some alternatives for older Emacsen. + (slime-find-buffer-package): Skip quotes. Old code looks + sometimes like (in-package 'foo). + (slime-repl-mode-map): Inhibit C-c C-z. Avoids accidental loading + inf-lisp. + (slime-net-coding-system): Use find-coding-system in XEmacs. + coding-system-p means something different here. + (slime-repl-mode-map): XEmacs compatibility: use (kbd "C-<up>") + instead of [C-up]. + + * swank.lisp (inspect-for-emacs-list): subseq on improper lists + breaks in Lispworks. Handle that case better. + + * swank-sbcl.lisp (inspect-for-emacs)[code-component]: Disassemble + code-components too. + + * swank-backend.lisp (import-swank-mop-symbols): Better error + message for the assertion. + + * swank-cmucl.lisp (debug-var-value): Return #:invalid or + #:unknown instead of :<not-available>. + (swank-compile-file): Load the fasl file only if load-p is true. + (inspect-for-emacs, inspect-alien-record, inspect-alien-pointer): + Add inspector support for some alien types. + + * swank-lispworks.lisp (emacs-connected): Set the sigint handler + only for single threaded operation. I.e. when + *communication-style* is nil. + + * swank-allegro.lisp (set-external-format): New function. Use LF + as eol mark. + (call-with-compilation-hooks): Trap compiler-notes too. + +2004-11-24 Luke Gorrie luke@synap.se + + * slime.el (slime-repl-mode-map): Add C-up and C-down to move + through history. Consistent with comint-mode. + (slime-repl-mode-map): Add slime-load-file on `C-c C-l' and + slime-compile-file on `C-c C-k'. This is mostly to override + unwanted inf-lisp bindings in lisp-mode-map. + (slime-load-file): Handle (buffer-file-name) being nil. + +2004-11-20 Helmut Eller heller@common-lisp.net + + * swank-sbcl.lisp (make-socket-io-stream): Add some #+sb-unicode. + +2004-11-20 Travis Cross travis@crosswirecorp.com + + * swank-sbcl.lisp (thread-status): Fix unbalanced parenthesis. + +2004-11-20 Marco Baringer mb@bese.it + + * swank-openmcl.lisp (make-stream-interactive): Only add ouptut + streams (subclasses of ccl:fundamental-output-stream) to + ccl::*auto-flush-streams*. + +2004-11-19 Helmut Eller heller@common-lisp.net + + * slime.el (slime-net-coding-system): New variable. Specifies the + coding system to use for network communication. The default is + iso-latin-1 and should work for all Lisps. Only a small set of + coding systems is currently supported. + (slime-net-valid-coding-systems): New variable. A list of coding + systems which may be used. + (slime-check-coding-system, slime-coding-system-mulibyte-p) + (slime-coding-system-cl-name): New utility function for coding + systems. + (slime-net-connect, slime-make-net-buffer, + slime-open-stream-to-lisp): Use it. + (slime-net-decode-length, slime-net-encode-length): Renamed from + slime-net-read3 and slime-net-enc3. The length is now encoded as + a 6 char hex string. + + * swank.lisp (*coding-system*): New variable. + (start-server): Accept external-format as argument. + (create-server, create-swank-server, setup-server) + (serve-connection, open-dedicated-output-stream) + (create-connection): Ditto. + (defstruct connection): Add external-format slot. + (decode-message-length): New function for new length encoding. + (decode-message): Use it. + (encode-message): Use new encoding. + + * swank-cmucl.lisp (accept-connection): Accept external-format + argument. + (inspect-for-emacs): Add CMUCL specific versions for array and + vectors. + + * swank-sbcl.lisp, swank-openmcl.lisp, swank-lispworks.lisp, + swank-clisp.lisp, swank-backend.lisp, swank-allegro.lisp, + swank-abcl.lisp (accept-connection): Accept :external-format as + argument. + +2004-11-19 Matthew Danish mrd+nospam@cmu.edu + + * swank-allegro.lisp: (count-cr): New function. Convert + file-offsets to match Emacs' eol-conventions. + (find-definition-in-file): Use it. + + * slime.el (slime-insert-xrefs): Display the multi-line label much + more cleanly. + +2004-11-19 Helmut Eller heller@common-lisp.net + + * swank-sbcl.lisp (thread-status): Decode the thread-state-slot + instead of returning ???. + + * swank-allegro.lisp (swank-mop:slot-definition-documentation): + ACL 7 says documentation should have 2 args. So, pass t as second + argument. + (fspec-primary-name): Recurse until we have a symbol. + (allegro-inspect): New function. Mostly reverse engineered from + ACL's native inspector. + (inspect-for-emacs (t), inspect-for-emacs (function)): Use it. + + * swank.lisp (inspect-for-emacs array): Use row-major-aref instead + of a displaced array. I hope that does the same. + (inspect-for-emacs integer): Ignore errors in + decode-universal-time. Negative values and, in SBCL, also small + values cannot be decoded. + (list-threads): Include the thread-id. Useful for SLIME debugging. + + * slime.el (slime-list-threads, slime-thread-insert): Show the + thread-id. + (slime-thread-control-mode-map): Remove the binding for the + no-longer-existent slime-thread-goahead command. + +2004-11-18 Alexey Dejneka adejneka@comail.ru + + * swank.lisp (inspect-for-emacs): Fix bug in handling of arrays + with fill-pointers. + +2004-11-15 Helmut Eller heller@common-lisp.net + + * slime.el: The REPL commands ,quit and ,sayoonara are now + distinct. Previously Quit killed all Lisps an all buffers. The + new Quit command kills only the current Lisp. + (slime-quit-lisp): New function. + (repl-command quit): Use it. Don't delete all buffers. + (repl-command sayoonara): No longer an alias for ,quit. + (slime-connection-list-mode-map): Bind C-k to slime-quit-lisp. + (slime-communication-style): New connection variable. + (slime-use-sigint-for-interrupt): Is no longer a connection local + variable. It's derived from the new slime-communication-style. + (slime-inhibit-pipelining): New user option. + (slime-background-activities-enabled-p): New predicate to control + various background activities like autodoc and arglist fetching. + (slime-space, slime-autodoc-message-ok-p): Use it. + (slime-search-call-site): Use hints provided to search a call-site + in a defun. Useful for the show-frame-source command. + (slime-goto-source-location): Use it. + (slime-quit): Deleted, as it was broken. May come back later. + (slime-inspector-label-face, slime-inspector-value-face) + (slime-inspector-action-face, slime-reader-conditional-face): + Provide better defaults for Emacsen which don't support :inherited + faces. + + * swank-backend.lisp (emacs-connected): Don't pass the stream as + argument. make-stream-interactive is a better place for setting + buffering options. + + * swank-cmucl.lisp (emacs-connected): Install GC hooks to display + GC messages in the echo area. + (sos/misc :flush-output): There seem to be funny signal safety + issues if the dedicated output stream is not used. So, lets first + reset the buffer index before sending the buffer to the underlying + stream. + + * swank-lispworks.lisp (frame-source-location-for-emacs): Pass the + function name of the next (newer) frame as a hint to Emacs. This + way we can highlight the call site in some cases, instead of the + entire defun. + (frame-location): Renamed from function-name-location. The + argument is now a dspec, not only a name. Also include hints for + Emacs. + (lispworks-inspect): Simplified from old code. + (inspect-for-emacs): Use it for also for simple functions. + (emacs-connected, make-stream-interactive): Move the + soft-force-output stuff to make-stream-interactive. + + * swank-abcl.lisp (emacs-connected): Deleted. The default + implementation should be good enough. + + * swank-sbcl.lisp (emacs-connected): Updated for new interface. + + * swank-openmcl.lisp (emacs-connected, make-stream-interactive): + Move buffering stuff to make-stream-interactive. + + * swank.lisp (defstruct connection): Add new slot: + communication-style for convenience. + (create-connection): Initialize the new slot. + (connection-info): Send the communication-style to Emacs. + (install-fd-handler, simple-serve-requests): Sending + :use-sigint-for-interrupt is no longer necessary. + +2004-11-11 Raymond Toy raymond.toy@ericsson.com + + * slime.el (slime-activate-font-lock-magic): Add XEmacs support. + (slime-reader-conditional-face): New face. + +2004-11-10 Marco Baringer mb@bese.it + + * swank-backend.lisp (definterface): Eliminate unused variable + received-args. + (emacs-connected, make-stream-interactive, condition-references, + condition-extras, buffer-first-change): Add (declare (ignore X)) + for unused arguments in default implementations. + (inspect-for-emacs): Remove (declare (ignore)) for inexistent + variable inspection-mode. Added T qualifiers in method arguments. + + * swank-openmcl.lisp (inspect-for-emacs): Use definterface so + SLIME knows we implement this. + (arglist function): Use ccl:arglist, not ccl::arglist-from-map. + (inspect-for-emacs): Added support for inspecting the uvector + objects under lisp datums. + +2004-11-09 Helmut Eller heller@common-lisp.net + + * swank.lisp (features-for-emacs): New function to avoid + keyword/string confusion. Case doesn't matter since Emacs will + downcase them anyway. + (connection-info, sync-features-to-emacs): Use it. Should fix + highlighting bug reported by Edi Weitz. + + * slime.el (slime-eval-feature-conditional): Convert AND, OR, and + NOT to lowercase keywords. + (slime-net-read3): Silly optimization: give char-after the offset + as argument to avoid save-excursion and forward-char. + +2004-11-07 Brian Downing bdowning@lavos.net + + * slime.el (slime-fuzzy-explanation): Added line to describe + flags (:boundp, :fboundp, :macro, etc), which are now reported in + the fuzzy-completion output. + (slime-fuzzy-insert-completion-choice): Added flags. + (slime-fuzzy-choices-buffer): Added flags header. + + * swank.lisp (fuzzy-completions): Changed docstring to describe + new flags in the completion results. + (convert-fuzzy-completion-result): New function to marshall the + results from the completion core into something Emacs is + expecting. Added flags. + (fuzzy-completion-set): Use the above. + (compute-completion): Removed. + (score-completion): Cleaned up a little bit. + (highlight-completion): Use destructive nstring-upcase. + +2004-11-01 Helmut Eller heller@common-lisp.net + + * slime.el (slime-easy-menu): Add item for + slime-update-indentation. Suggested by Lynn Quam. + (slime-severity-faceslime-show-note-counts) + (slime-most-severe, slime-choose-overlay-region): Handle + read-errors. + (slime-show-buffer-position): New function. + (slime-show-source-location): Use it. + + * swank-backend.lisp (deftype severity): Add read-errors. + + * swank-cmucl.lisp (severity-for-emacs): Special case read-errors. + (read-error-location): Add the offset to the buffer start. + + * swank.lisp (assign-index): Avoid linear search. + +2004-10-30 Helmut Eller heller@common-lisp.net + + * swank-source-path-parser.lisp (source-path-stream-position): + Bind *read-suppress* only as long as we skip over forms. The last + toplevel form in the path is read with *read-suppress* = nil + because in newer versions of CMUCL and SBCL read will return nil + if *read-suppress* is t. + +2004-10-28 Helmut Eller heller@common-lisp.net + + * swank-clisp.lisp: Ups. Undo previous change. + + * swank-clisp.lisp: Add workaround for CLISP's broken control + string parser. + + * swank-cmucl.lisp (set-step-breakpoints): Handle breakpoints at + single-return points in escaped frames better. Previously we + tried to set a breakpoint at the current position and consequently + was only hit during the next call. + (inspect-for-emacs)[function]: Call the next method only for + funcallable instances. + (profile-report, profile-reset, unprofile-all): We have to use + eval because the macro expansion depends on the value of + *timed-functions*. Reported by Chisheng Huang. + + * slime.el (slime-space): Call slime-message in the right buffer, + so that after-command hooks are added in the right buffer. + Reported by Juho Snellman. + (slime-dispatch-event): Accept stepping flag. + (sldb-setup): Don't query when entering a recursive edit. + (sldb-exit): Don't kill the buffer if we are in stepping mode. + (slime-inspector-insert-ispec): New function. + (slime-open-inspector): Use it. + (slime-inspector-operate-on-point): Simplified. + (test interactive-eval): Fix test case. + (slime-kill-all-buffers): More regexp kludges. From Bill Clementson. + + * swank-backend.lisp (activate-stepping): New function. + + * swank.lisp (*sldb-stepping-p*): New variable. Used to tell + emacs that the debugger buffer should not be closed even if we + unwind. + (debug-in-emacs): Use it. + (sldb-step): Moved to the front end. + (inspector-princ, method-specializers-for-inspect): Simplified. + (methods-by-applicability): Use a simpler algorithm. I doubt there + is much difference in practice. + (inspect-for-emacs)[symbol, function, standard-generic-function] + [standard-method]: Use less than 80 columns. + (inspector-call-nth-action): Don't accept &rest args. Was never + used. + (inspect-for-emacs) [integer]: Fix control string. Thanks to CSR + for pointing it out. + +2004-10-27 Helmut Eller heller@common-lisp.net + + * swank-sbcl.lisp (signal-compiler-condition): Actually delete one + of the reader-conditionalized forms. + +2004-10-26 Helmut Eller heller@common-lisp.net + + * cl-indent.el: Add indentation specs for some missing CL symbols. + (lisp-prefix-match-indentation): Change default to + nil to avoid confusion for people who don't care about the issue. + + * swank-sbcl.lisp (signal-compiler-condition): Remove reader + conditionals as the current code doesn't work in any SBCL before + 0.8.13 anyway. + + * swank-source-path-parser.lisp: Remove workarounds for SBCL bugs. + The bugs are fixed in the versions we support. + + * swank-cmucl.lisp (read-error-location) + (signal-compiler-condition): Handle read-errors. + (swank-compile-file): Don't load the fasl file if there was an + error. + + * swank.lisp (define-printer-variables): Handle doc strings + properly. + (*sldb-pprint-dispatch*): Initialize it with the default dispatch + table. + + * slime.el (slime-init-command): New function to send the command + to load swank. Having a separate function for the task should + make it easier to start a Lips with a preloaded swank. + (slime-maybe-start-lisp): Use it. + (slime-maybe-start-multiprocessing): Deleted. + (slime-repl-buffer): Include the name of the implementation. + (slime-set-default-directory) + (slime-sync-package-and-default-directory): Translate filenames. + +2004-10-25 Marco Baringer mb@bese.it + + * swank.lisp (inspect-for-emacs array): Properly deal with arrays + without fill pointers. + (inspect-for-emacs function): Show function-lambda-expression + when available. + + * swank-openmcl.lisp (specializer-name): New function. + (who-specializes): Use it. + (maybe-method-location): Use it. + (function-source-location): Use it. + + * swank-cmucl.lisp (inspect-for-emacs function): Use next + method's values and simply add cmucl specific details. + + * slime.el (slime-repl-defparameter): Change default value to "*". + +2004-10-25 Thomas Schilling tjs_ng@yahoo.de + + * swank-allegro.lisp (inspect-for-emacs): Use + excl::external-fn_symdef to get the function documentation. + + * swank.lisp (inspect-for-emacs): Order generic function's methods + and show abbreviated docs for methods. + (abbrev-doc): New function. + (methods-by-applicability): New function. + (*gf-method-getter*): New variable. + +2004-10-19 Luke Gorrie luke@synap.se + + * slime.el (slime-show-source-location): Call `push-mark' to push + the source position onto the global mark ring. + +2004-10-19 Helmut Eller heller@common-lisp.net + + * swank.lisp (define-printer-variables): NIL is not a valid + docstring. Reported by Alain Picard. + (printer-variables sldb-print): Include print-gensym, + pprint-dispatch, base, radix, array, and lines. + +2004-10-17 Luke Gorrie luke@synap.se + + * slime.el (slime-message): Use slime-typeout-frame if available. + +2004-10-17 Helmut Eller heller@common-lisp.net + + * cl-indent.el: Our local copy. Should eventually be merged the + file with in the main distribution. + + * slime.el: (slime-find-buffer-package-function): New variable to + allow customization for unusal syntax. + (slime-maybe-rearrange-inferior-lisp): Removed unused function. + (slime-set-inferior-process): Non-macro version to make + byte-compiler happy. Reported by Raymond Wiker. + (slime-maybe-start-lisp): Use it. + (slime-sync-package-and-default-directory): Synch the + default-directory in the REPL buffer too. + (slime-goto-connection): Close the connection list window. + Suggested by Andras Simon. + (slime-repl-clear-buffer): Place point after the prompt. + (selector-method ?i): Use slime-process to switch to the right + buffer. + (slime-background-message): Do nothing if the minibuffer is + active. + (slime-indent-and-complete-symbol): Don't indent if we at the same + line as the prompt. + + * swank.lisp (*sldb-pprint-frames*): Renamed to + *sldb-print-pretty*. + (*sldb-print-level*, *sldb-print-length*, *sldb-print-circle*) + (*sldb-print-readbly): Group of new variables to customize + printing in the debugger. The default values should be safe. + (define-printer-variables, with-printer-settings): New macros to + make defining and binding groups of printer variables easier. + (inspect-for-emacs-list): Fix bug with circular lists and only + shows the first 40 elements. + (inspect-for-emacs): Various cleanups. + (all-qualified-readnames): Removed. It was not needed because + common-lisp-indent-function strips of any package prefix and + downcases the symbol anyway. + (printer-variables sldb-print): Ooops. Better use sldb-print as prefix + than sldb alone. *sldb-level* was already defined. + + * swank-cmucl.lisp (inspect-for-emacs (code-component)): + Disassemble the memory region if there's not enough debug info. + +2004-10-17 Jan Rychter jan@rychter.com + + * swank-cmucl.lisp (return-from-frame): Add it. + +2004-10-11 Thomas F. Burdick tfb@OCF.Berkeley.EDU + + * swank-sbcl.lisp (function-definitions): Find compiler macros, too. + (find-defintions, compiler-definitions) + (optimizer-definitions, transform-definitions): Add compiler + transformers and optimizers to the list of definitions. + +2004-10-07 Peter Seibel peter@javamonkey.com + + * swank.lisp (spawn-threads-for-connection): Bind *debugger-hook* + instead of SETF'ing it. + +2004-10-06 Luke Gorrie luke@synap.se + + * swank.lisp (update-indentation/delta-for-emacs): Configure Emacs + indentation settings not just for the symbol name but for all + package-qualified forms of it as well. + + * doc/slime.texi (Credits): Updated the credits list to include + more Lisp implementors who're also SLIME hackers. + +2004-10-05 Luke Gorrie luke@synap.se + + * swank.lisp (arglist-for-echo-area): Handle errors and return a + message. + (parse-symbol): Recognise an empty package name as the KEYWORD + package. + +2004-10-03 Reini Urban rurban@x-ray.at + + * swank-clisp.lisp (getpid)[win32]: Use + win32:|GetCurrentProcessId|. + +2004-10-03 Helmut Eller heller@common-lisp.net + + * slime.el: Reduce dependency on inf-lisp internals. Make it + possible to start the inferior lisp in a buffer different from + "*inferior-lisp*". + (slime): Parse the command argument explicitly and don't rely on + `inferior-lisp'. Don't close all connections, but only the one + for the inferior lisp buffer we are using. + (slime-maybe-start-lisp): Take the command and buffer as argument. + Decide here whether we should start start a new processwe or just + disconnect and reconnect . + (slime-start-lisp): Load verbosely. + (slime-inferior-lisp): New function. Replaces call to + `inferior-lisp'. + (slime-inferior-connect, slime-start-swank-server): Take the + inferior process as argument + (slime-read-port-and-connect): Set the slime-inferior-process + variable in the new connection. + (slime-inferior-process): New connection local variable. + (slime-process): Use it. + (slime-restart-inferior-lisp): Don't use inferior lisp stuff. + (slime-switch-to-output-buffer): Process interactive arguments + properly. + + * swank-loader.lisp (compile-files-if-needed-serially): Load + verbosely. + +2004-10-01 Helmut Eller heller@common-lisp.net + + * swank-allegro.lisp (find-fspec-location): excl:source-file can + return stuff like (:operator ...); try to handle it. + + * swank-cmucl.lisp (code-component-entry-points): Only include + entry points with "valid" functions names. This excludes internal + lambdas which have usually a string as name, like "defun foo". + + * swank.lisp (parse-symbol): Don't use the reader to avoid + interning unknown symbols. The downside is that we no longer + handle escaped |symbols| correctly. + + * slime.el (slime-set-connection-info): Hide the *inferior-lisp* + buffer after we know Lisp's pid. Print the words of encouragement + here, when all the other asynchronous initialization is completed. + (slime-find-buffer-package): We need to preserve the case for + things like (:in-package "foo"), so return ""foo"". + +2004-09-27 Helmut Eller heller@common-lisp.net + + * slime.el (slime-process): New function intended to replace all + those references to the *inferior-lisp* buffer. + (slime-maybe-start-lisp): Split it up. + (slime-start-lisp): New function. + (slime-restart-inferior-lisp): Use the command from the existing + process to start the new process. + +2004-09-27 Christian Lynbech christian@defun.dk + + * slime.el (define-slime-dialect): New macro to make starting + Lisps with different command line options easier. + +2004-09-27 Rui Patroc�nio rui.patrocinio@netvisao.pt + + * swank.lisp (mop, mop-helper): Support functions for the class + browser. + + * slime.el (slime-browse-classes, slime-browse-xrefs): New + commands to browse class hierarchies and xref graphs in a tree + widget. + + * tree-widget.el: New file. Only needed for older Emacsen. + +2004-09-23 Helmut Eller heller@common-lisp.net + + * slime.el (slime-start-and-load): Take arguments so that the + function can be called non-interactively. Only start SLIME is if + it is not running. + (slime-recompile-bytecode): Don't warn about uses of cl-functions. + (slime-reset): Kill all sldb buffers. + (slime-goto-location-position): Fix syntax for Emacs 20. + (sldb-mode-map): Add C-c C-d bindings. + (slime-open-inspector): Insert the type in the second line so that + we can make longer titles, e.g we should include the princed + version of the inspected object. + + * swank-backend.lisp (frame-package, label-value-line) + (label-value-line*): New functions. + + * swank.lisp (frame-locals-for-emacs): Bind *print-pretty* to + *sldb-pprint-frames* to get more compact lines and bind *package* + to frame-package to get shorter labels for variables. + (format-values-for-echo-area): Include the hex and octal + representation for integers. + (apply-macro-expander, disassemble-symbol): Use the buffer-package + for reading. + (inspector-content-for-emacs): Use print-part-to-string so that we + see cycles in the data structure. + (inspect-for-emacs): Minor beautifications. + (load-file-set-package): New function. + + * swank-cmucl.lisp (frame-package): Implemented. + (inspect-for-emacs): Only include stuff that is actually stored in + the object itself (see objdef.lisp for exact object layout). + Include the disassembly for functions and code components. + +2004-09-19 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-gray.lisp (stream-read-char): Treat empty strings as + end-of-file. + + * swank-cmucl.lisp (sis/in): Treat empty strings as end-of-file. + (map-allocated-code-components): Inhibit efficiency notes. + (arglist)[symbol] Delete unreachable code. + (sldb-break-on-return, sldb-break-at-start): Implement it + (sldb-step): Some cleanups. + + * swank.lisp (thread-for-evaluation): Restart the listener thread + if it was dead for some reason. + (debugger-condition-for-emacs): Include "extra" stuff. Currenlty + only used to pop up the source buffer at breakpoints. + (sldb-break): New function. + (interrupt-worker-thread): Interrupt the repl thread if there is + no other active thread. + + * swank-backend.lisp (import-swank-mop-symbols): New + function. Useful if the implementation has most of the mop symbols + in the same package. + (sldb-break-on-return, sldb-break-at-start, condition-extras): New + functions. + + * slime.el (sldb-break-on-return, sldb-break): New commands. + (slime-repl-return-string): Allow empty strings. That's our way + to send end-of-file. + (sldb-insert-condition): Add "extra" slot for random thing that + don't fit nicely somewhere else. + (sldb-dispatch-extras): New function. + (sldb-show-frame-source): New non-interactive version of + sldb-show-source. + (sldb-show-source): Use it. + (slime-beginning-of-symbol, slime-end-of-symbol): New functions + which don't include the character after a hash '#'. + (slime-symbol-name-at-point): Use them. + (slime-symbol-start-pos, slime-symbol-end-pos): Ditto. + +2004-09-17 Marco Baringer mb@bese.it + + * swank.lisp: Don't print "Documentation:" if none is available; + add support for classes specializer-direct-methods; deal with + eql-specializers in methods. + (inspector-princ): New function. + (method-specializers-for-inspect): New function. + (method-for-inspect-value): New function. + (inspect-for-emacs): Use inspector-princ instead of + princ-to-string. + + * swank-backend.lisp (swank-mop): Require eql-specializer, + eql-specializer-object and specializer-direct-methods in swank-mop + package. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-openmcl.lisp, swank-sbcl.lisp (swank-mop): Export + eql-specializer, eql-specializer-object and + specializer-direct-methods from swank-mop. + + * swank-cmucl.lisp (inspect-for-emacs): Thinko fix. + + * swank-lispworks.lisp (swank-mop): Export + specializer-direct-methods. + (eql-specializer): Implement. + (eql-specializer-object): Implement. + + * swank-sbcl.lisp (inspect-for-emacs): Fix broken ignore + declaration. + + * doc/slime.texi: Update inspector documentation. + +2004-09-16 Marco Baringer mb@bese.it + + * swank-clisp.lisp (swank-mop, inspect-for-emacs): Only define the + CLOS parts of the inspector if the underlying lisp provides the + required functionality. If not enough MOP is present to implement + the inspector then we define some very simple replacement methods. + +2004-09-16 Marco Baringer mb@bese.it + + * swank-clisp.lisp (swank-mop): Implement the MOP compatability + package. + (inspect-for-emacs): Update for new inspection API. + +2004-09-15 Alan Ruttenberg alanr-l@mumble.net + * swank-openmcl: typo in who-references. Fix frame-var-value + +2004-09-15 Marco Baringer mb@bese.it + + * slime.el (slime-inspector-label-face, + slime-inspector-value-face, slime-inspector-action-face, + slime-inspector-type-face): These faces now inherit from similar + font-lock-<whatever> faces. + (slime-open-inspector): Use slime-inspector-value-face for values. + + * swank.lisp (inspect-for-emacs): Add function and compiler-macro + documentation when inspecting symbols. View the truename of + logical pathnames where they exist. Fix typos in package + inspector (fix by Torsten Poulin torsten@diku.dk). + + * swank-sbcl.lisp, swank-cmucl.lisp (inspect-for-emacs): Insert + function object's documentation when it's available. + +2004-09-15 Eduardo Mu�oz emufer@terra.es + + * .cvsignore: Added *.elc + + * hyperspec.el: Fixed syntax error. + +2004-09-15 Alan Caulkins fatman@maxint.net + + * swank.lisp (cleanp-connection-threads): Kill all Swank threads + for a connection when it terminates. + +2004-09-14 Thomas Schilling tjs_ng@yahoo.de + + * swank-allegro.lisp (inspect-for-emacs): Fixes to previous patch. + +2004-09-14 Marco Baringer mb@bese.it + + * swank-backend.lisp (inspector, make-default-inspector): Add an + INSPECTOR object argument to the inspector protocol. This allows + implementations to provide more information regarding cretain + objects which can't be, or simply aren't, inspected using the + generic inspector implementation. also export inspect-for-emacs + and related symbols from the backend package. + (make-default-inspector): New function. + + * swank.lisp (inspected-parts): Rename to inspect-for-emacs and + add an inspector argument. Move inspect-for-emacs to + swank-backend.lisp, leave only the default implementations. + + * swank-openml.lisp, swank-sbcl.lisp, swank-allegro.lisp, + swank-cmucl.lisp, swank-lispworks.lisp (inspected-parts): Rename + and change argument list. Many of the inspected-parts methods were + being clobbered by the inspected-parts in swank.lisp, now that + they're being used the return values have been updated for the new + inspect-for-emacs API. + +2004-09-14 Thomas Schilling tjs_ng@yahoo.de + + * swank-allegro.lisp (inspected-parts): Implement inspector for + structs. + +2004-09-13 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp (intern-catch-tag): New function. + (read-user-input-from-emacs, take-input): Use it. + +2004-09-13 John Paul Wallington jpw@gnu.org + + * swank.lisp (define-special): Make the doc-type `variable' + rather than `symbol'. Don't quote `doc'. Doc fix. + +2004-09-09 Martin Simmons martin@xanalys.com + + * swank-lispworks.lisp: Set up the swank-mop package. Implement + swank-mop:slot-definition-documentation and function-name. + +2004-09-13 Marco Baringer mb@bese.it + + * swank.lisp (inspected-parts): Added inspectors for pathnames, + logical pathnames, standard-objects and numbers (float, ratio, + integer and complex). + + * swank-backend.lisp: Define import-to-swank-mop. + + * swank-openmcl.lisp, swank-sbcl.lisp, swank-allegro.lisp: Don't + define the import-to-swank-mop function (now defined in + swank-backend.lisp). + + * swank-cmucl.lisp (swank-mop, function-name): Implement backend + for inspector. + (arglist): Add support for extracting arglists from function + objects. + (create-socket): Don't specify the host on PPC. + +2004-09-13 Alan Ruttenberg alanr-l@mumble.net + + * slime.el slime-goto-location-position: New location specifiers: + (:method name specializers . qualifiers) all are strings. Looks + for defxxx name then the qualifiers as words, in order then the + specializers as words, in order (except for "T", which is + optional). Pass the symbols names for specializers and qualifiers + (no packages). Used by openmcl but might be useful for others + (:text-anchored <position fixnum> <string> <delta fixnum>) + Got to position, then search for string, then move delta. To + support upcoming source recording for openmcl debugging. + + * swank-openmcl multiple changes: - fix support for *sldb-top* + (formerly *swank-debugger-stack-frame*) Was not thread safe. Now + (application-error), and (interrupt-thread) records the error + pointer in a table associated with thread and map-backtrace picks + up the appropriate pointer. *process-to-stack-top*, + (grab-stack-top), (record-stack-top). + + - Other adjustments for changes to multiprocessing: remove + (force-break-in-listener) no longer necessary since we use + process-interrupt instead of ccl::*interactive-abort-process* + Adjust break-in-sldb to do so for swank repl connections + (abstraction breaking reference to swank::*connections*, but + nicely via intern) + + - changes to (find-definitions) (function-source-location), + addition of (maybe-method-location) (remove-filename-quoting). To support + editing definitions of methods. To fix bug with pathnames with + quoted characters (like "\.swank.lisp"). To remove bogus source + recording of l1-boot-3 in functions that didn't have a source file + noted. + + - Implementation of xref functions: (xref-locations) uses xref + implementation added to openmcl recently. Note that you have to + (ccl::start-xref) for it to work for other than who-calls, and + that xref information is not currently persisted in fasl files (I + will release a patch for this soon) Backend functions (who-binds) + (who-macroexpands) (who-references) (who-sets) + (who-calls) (list-callees) (who-specializes) + + - Lifted profile backend functions from swank-clisp which use + "metering.lisp" + + - (openmcl-set-debug-switches) turns on the various variables I. + know about that have the lisp record extra debugging + information(including starting xref). I suggest you call + it. Should it be called by default? + + - (frame-arguments) use builtin ccl::frame-supplied-args since the + current version was sometimes missing the first argument to the + function. (I think this was when it was passed by register. If you + don't want to lose it in the frame locals in backtrace, call + (openmcl-set-debug-switches) specifically, set + ccl::*ppc2-compiler-register-save-label* to t + + - implement frame-var-value backend + + * metering.lisp: Minor changes to #+ #- to recognize openmcl + + * swank-loader.lisp: Load "metering.lisp" + +2004-09-13 Marco Baringer mb@bese.it + + * swank.lisp (inspected-parts): Deal with unfinalized classes in + standard-class inspector. (Patch from Thomas Schilling) + +2004-09-13 Marco Baringer mb@bese.it + + * swank.lisp: New inspector protocol. The lisp side now returns a + specially formated list of "things" to format which are then + passed to emacs and rendered in the inspector buffer. Things can + be either text, recursivly inspectable values, or functions to + call. + (inspected-parts): Redefine for new inspector protocol. + (*inspectee-parts*): Redefine as array. + (*inspectee-actions*): New array, similar to *inspectee-parts*. + (reset-inspector): Update for new implementation of + *inspectee-parts* and new variable *inspectee-actions*. + (inspector-contents-for-emacs): New function. + (inspect-object): Update for new inspector protocol. + (inspector-nth-part): Update for new *inspectee-parts* + implementation. + (inspector-call-nth-action): New function. + + * slime.el (slime-inspector-action-face): New face. + (slime-open-inspector): Adapt to new inspector protocol. + (slime-inspector-operate-on-point): New function, subsumes + slime-inspector-inspect-object-at-point. + (slime-inspector-next-inspectable-object): Skip to next object, + not just end of current object; wrap around buffer. + (slime-inspector-mode-map): change bindings of [return] and "\C-m" + + * swank-bacend.lisp (swank-mop): New package. Simply defines all + the MOP related symbols we need from an implementation. + (arglist): Update doc string. Provide default implementation. + (function-name): New backend function. + + * swank-allegro.lisp (swank-mop, slot-definition-documentation): + Implement. (Patch from Thomas Schilling) + + * swank-sbcl.lisp (swank-mop, slot-definition-documentation, + function-name): Implement. + + * swank-openmcl.lisp (swank-mop, function-name): Implement. + (arglist): Implement for function objects. + +2004-09-12 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp (compile-file-for-emacs): Use with-buffer-syntax so + that SBCL source files can be compiled. From Christophe Rhodes. + +2004-09-09 Martin Simmons martin@xanalys.com + + * swank-loader.lisp (make-swank-pathname): Preserve the host + component (important for LispWorks on Windows). + +2004-09-08 Martin Simmons martin@xanalys.com + + * swank-lispworks.lisp: Implement call-with-compilation-hooks. + +2004-09-03 Helmut Eller e9626484@stud3.tuwien.ac.at + + * NEWS: Summarize changes since August. + + * slime.el: Add some docstrings. + + * mkdist.sh: Add PROBLEMS file. We're no longer alpha. + + * swank.lisp: Remove debugging code in comment. + + * swank-sbcl.lisp: Delete dead code. + + * swank-lispworks.lisp (defimplementation): define-dspec-alias + seems to more apropriate than define-form-parser. + + * swank-cmucl.lisp (print-frame): Catch errors during printing. + + * README: Fix typo. + +2004-09-02 Wolfgang Mederle wolfgang.mederle@stud.uni-muenchen.de + + * swank-loader.lisp (*lisp-name*): Replace / with - in CMUCL + version strings. + +2004-09-01 John Paul Wallington jpw@gnu.org + + * slime.el (slime-oneliner): Don't use free variable. + (slime-recenter-window, slime-set-connection-info) + (slime-pprint-event, slime-compiler-notes-quit) + (slime-apropos-summary): Likewise. + (slime-connect): Tidy up handshake `message' call. + +2004-09-01 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-repl-push-directory): Fix interactive spec. + (sldb-reference-properties): Take a the reference object as + argument instead of its parts. Fix callers accordingly. + (slime-fuzzy-choices-buffer): Remove assignment to unused variable + slime-fuzzy-target-mtime. + (slime-ed): Replace call to new-frame with make-frame. + (sldb-find-buffer): Cleanup. + (sldb-highlight-sexp): Fix regexp. It's now almost a full line. + + * swank.lisp (completion-set, tokenize-symbol-designator) + (tokenize-completion, fuzzy-completion-set) + (briefly-describe-symbol-for-emacs): Remove simple-base-string + declarations. + +2004-08-30 Helmut Eller e9626484@stud3.tuwien.ac.at + + * PROBLEMS: We require SBCL 0.8.13. 0.8.12 is no longer + supported. + + * swank-allegro.lisp (find-fspec-location): Catch errors in + excl:source-file. + + * swank.lisp (send-to-socket-io): Add some ignore declarations. + + * slime.el (sldb-fetch-all-frames, sldb-end-of-backtrace) + (sldb-beginning-of-backtrace): New commands. + (slime-search-suppressed-forms): Change the start regexp so that + reader conditionals in single line comments, like "; #+foo", are + ignored. + +2004-08-27 Peter Seibel peter@javamonkey.com + + * swank-backend.lisp (swank-compile-string): Add directory + argument which is used by Allegro backend to improve source + recording for definitions compiled with C-c C-c. + +2004-08-23 John Paul Wallington jpw@gnu.org + + * slime.el (slime-pretty-package-name): Fix last cond clause. + +2004-08-21 Luke Gorrie luke@bluetail.com + + * swank.lisp (*global-debugger*): New configurable to globally + install swank-debugger-hook as *debugger-hook*. True by default. + +2004-08-19 Luke Gorrie luke@bluetail.com + + * doc/slime.texi: C-c C-c C-a, C-c C-u C-e. + Thanks Barry Fishman for reporting incorrect indexing. + +2004-08-18 Matthew Danish mrd+nospam@cmu.edu + + * swank-allegro.lisp (swank-compile-string): Use #; instead of + #: to separate the position from the buffer-name. This avoids + troubles on Windows. + +2004-08-16 Luke Gorrie luke@bluetail.com + + * doc/slime.texi: Random updates. + + * slime.el (slime-space): Use slime-message instead of + slime-background-message. This displays multi-line arglists. + (sldb-mode-map): Bind 'C' to sldb-inspect-condition. + +2004-08-14 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-find-buffer-package): Use "%s", not "%S", to + avoid ugly escape characters, if the package name contains dots. + +2004-08-13 Luke Gorrie luke@bluetail.com + + * slime.el (sldb-eval-in-frame): Print result to the REPL when a + prefix argument is given. + Added pull-down menus for SLDB and the REPL. + + * swank-source-path-parser.lisp: Removed caching of readtables and + the source-map hashtable. Fresh creation is ultra-cheap (<1ms). + The caching didn't handle modifications to readtables and + generally made me feel uneasy while tracking down an obscure bug + in a reader macro. + The cached source-map hashtable also wasn't thread-safe (ho hum). + +2004-08-13 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-merge-notes, slime-tree-for-note): Use the short + note message for annotation in the source buffer and the long + message in the tree widget. Used to be the other way around. + (sldb-insert-frames): Set the `start-open' property for XEmacs. + Without `start-open', the `point-entered' property is inherited + when we insert something before the "--more--" marker. Reported + by Sundar Narasimhan. + + * swank.lisp (variable-desc-for-echo-area): Bind some printer + variables to limit the length of the output. + +2004-08-05 Luke Gorrie luke@bluetail.com + + * slime.el (slime-setup): Added typeout-frame keyword argument. + (slime-thread-attach): Fixed misnamed function call. + +2004-08-04 Luke Gorrie luke@bluetail.com + + * swank-allegro.lisp (find-fspec-location): Fixed to work for more + types of definition than just functions. So M-. now works for e.g. + classes in Allegro. From Matthew Danish. + (find-fspec-location): Include the type of the definition in the + designator sent to Emacs. From Matthew Danish. + +2004-08-04 Martin Simmons martin@xanalys.com + + * swank-lispworks.lisp (frame-actual-args): Correct syntax for + handler-case. + +2004-08-04 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: (slime-mode-map, slime-repl-mode-map) + (slime-repl-read-mode-map): Remove the binding for C-c C-g. C-c + C-b is now the default interrupt key. + (slime-list-repl-short-cuts): Don't trash the shortcut-table: copy + it before sorting. (Thanks to Mark Simpson.) + +2004-08-02 Luke Gorrie luke@bluetail.com + + * slime.el (slime-connect): Shorten the welcome message by leaving + out the port number (which is displayed in the REPL anyway). This + avoids line-wrapping some messages of encouragement. + + * swank.lisp (with-buffer-syntax): Don't bind *readtable* to + *buffer-readtable* if they are already EQ. When we shadow this + binding the user can't assign *readtable* from the REPL so it's + best avoided when possible. + + * swank-allegro.lisp: Removed fwrapper-based code for inheriting + "swankiness" to newly spawned threads. This was fighting the + system and not the right thing. + + * slime.el (slime-choose-overlay-region): Tweaked the + multiline-annotation-avoidance code to work with forms not + starting with an open-paren, e.g. `(..) or #'(..). + (slime-update-modeline-package): New configurable. Non-nil (the + default) means update the Lisp package in the modeline using an + idle timer. + (slime-repl-send-input): Make the `slime-repl-old-input' property + cover the whole input (including newline) so that pressing RET on + the end of an input line works. + Use a unique integer as the value of this property to distinguish + adjacent inputs. + (slime-current-package): Deal with narrowing. + +2004-08-01 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-allegro.lisp (swank-compile-string): Use a temporary file + and set excl::*source-pathname* manually. This way we can find + the source buffer of functions compiled with C-c C-c. + (call-with-temp-file, compile-from-temp-file): New functions. + (list-callers, function-callers, in-constants-p) + (map-function-constants): Implements list callers by groveling + through the constants pools of named functions. + + * swank-lispworks.lisp: Minor refactoring. + +2004-07-30 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-connection): Say "No default connection + selected" if there are open connections but no default connection. + (slime-tree-indent-item): Point wasn't updated correctly if the + last line was empty. Use insert-before-markers instead of insert + to do it properly. + (slime-draw-connection-list): Don't break if there is no default + connection. + + * swank-cmucl.lisp (call-with-debugging-environment): Only handle + DI::UNHANDLED-CONDITION not all DI:DEBUG-CONDITIONs. + + * swank-backend.lisp (sldb-condition): Show the original condition + in the message. + +2004-07-28 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-eval-feature-conditional): Treat uppercase + operators NOT, AND, OR correctly. + (sldb-find-buffer): Remove killed buffers. + (sldb-quit): Raise an error if the RPC returns. + (slime-expected-failures): Delete unused function. + (complete-symbol): Test completion of + swank::compile-file. LispWorks has extra completions for + cl::compile-file. + (arglist): Test arglist of method cl:class-name. Add enough + regexpery to pass the test in most implementations. + + * swank-sbcl.lisp (list-callers, list-callees): Implemented. + +2004-07-26 Luke Gorrie luke@bluetail.com + + * slime.el (slime-first-change-hook): Add `save-match-data' to + avoid breaking e.g. query-replace. Also added `save-excursion' + just to be safe. + + * README: s/setup-slime/slime-setup/ in the .emacs snippet. + +2004-07-23 Luke Gorrie luke@bluetail.com + + * slime.el (slime-set-state): Show the message in the modeline in + the case where we aren't connected. Otherwise the "not connected" + status is ignored. + (slime-net-sentinel): Close the connection before changing the + status message. The old behaviour of this combined with the old + behaviour of `slime-set-state' could generally cause spurious + errors after a connection was closed. + +2004-07-22 Luke Gorrie luke@bluetail.com + + * swank.lisp (carefully-find-package): Return *BUFFER-PACKAGE* if + no other package can be found. This is reverting a previous change + that broke completion in buffers with no known package. + + * slime.el (slime-maybe-start-lisp): Check that *inferior-lisp* + exists /and/ has a running process. Fixes a startup problem if + your inferior-lisp has died and you want to restart SLIME. + +2004-07-21 Luke Gorrie luke@bluetail.com + + * slime.el (slime-sync-package-and-default-directory): Sync + `default-directory' in the REPL buffer too. + (slime-set-state): Convenience function for setting a connection's + state-name and updating the modeline if appropriate. This function + is called in the right places. + (slime-to-lisp-filename): Use `expand-file-name'. + +2004-07-20 Luke Gorrie luke@bluetail.com + + * slime.el (slime-repl-update-banner): Restore old behaviour of + using an asynchronous evaluation to setup the REPL. This works + around a problem I'd reintroduced where the first REPL command + uses the wrong keymap. + +2004-07-20 Andreas Fuchs asf@boinkor.net + + * swank-sbcl.lisp (call-with-compilation-hooks): Trap and report + errors that cause compilation to fail, e.g. read errors. + +2004-07-19 Luke Gorrie luke@bluetail.com + + * HACKING: Updated. Some notes about Emacs features. + + * slime.el: More major refactoring. + Restructured and documented the networking and protocol code. + (slime-rex-continuations): Now connection-local. + +2004-07-18 Luke Gorrie luke@bluetail.com + + * slime.el: Major refactoring. + Mostly resectioning and reordering definitions to try and improve + readability. + (slime-get-temp-buffer-create): New utility function to popup a + temporary buffer that automatically has a binding on `q' to + intelligently restore window configuration. Handy, but currently + not applicable to all of our temporary buffers. + (slime-with-chosen-connection): Removed this macro. Consequently + the compilation commands no longer prompt for which connection to + use when given a prefix argument. `slime-switch-to-output-buffer' + still works like that, but for other cases I think the + connection-list buffer is sufficient. + (slime-eval-async): New arglist: (form &optional cont pkg). If the + continuation is unspecified then the evaluation result is ignored, + and if the package is unspecified then (slime-buffer-package) is + used. + (slime-eval): Package arg now defaults to (slime-buffer-package). + (slime-current-package): New name for (slime-buffer-package). No + more caching: returns the buffer-local `slime-buffer-package' if + set, otherwise searches for an `in-package' form. + A consequence of non-caching is that the package name doesn't + appear in the modeline anymore. The simplification is worthwhile + in my opinion. + +2004-07-17 Luke Gorrie luke@bluetail.com + + * slime.el (slime-autodoc): If there is a global variable name at + point then show its value. + (slime-autodoc-cache-type): Cache type 'full is no longer + supported. + (slime-background-message): Truncate messages to fit on a single + echo area line. + (slime-repl-update-banner-p, slime-dont-prompt) + (slime-swank-connection-retries): Removed these unused or unuseful + configuration variables. + Rearranged organised "customize" groups. + + * swank.lisp (variable-desc-for-echo-area): New function. + (arglist-for-echo-area): Return nil if symbol can't be found. + (close-connection): Close connection before printing error + message. This avoids it getting lost in closed I/O redirection. + + * README, doc/slime.texi: Updated setup instructions. + +2004-07-16 Luke Gorrie luke@bluetail.com + + * slime.el (slime-conservative-indentation): New variable. When + true (the default) don't auto-learn indentation of def* and with-* + macros. Set to nil if you want to learn them. + (slime-handle-indentation-update): Use it. + + * swank.lisp (known-to-emacs-p): Removed filtering of def* and + with-*. Now handled by Emacs. + + * slime.el (slime-interactive-eval): Changed display of results. + By default the result goes to `slime-message', which leads either + to echo area, temporary buffer, or typeout frame. + With a prefix argument the result is printed to the REPL. + This goes for all commands based on slime-interactive-eval, e.g. + `C-x C-e' and `C-c M-:'. + +2004-07-16 Peter Seibel peter@javamonkey.com + + * slime.el (package-updating): Fixing this and other tests I broke + with my change to how emacs keeps track of the package prompt + string. + (arglist): Fix an test failure under Allegro due to a slight + difference in the way EXCL:ARGLIST returns arglist (no default + values of &optional parameters) + +2004-07-16 Luke Gorrie luke@bluetail.com + + * swank.lisp (print-connection): print-function for connection + objects. Dumping the indentation-cache was damned ugly with + non-truncated lines (e.g. bug reports on slime-devel). + + * slime.el (slime-setup): New function for installing a + lisp-mode-hook. You can call this from ~/.emacs to setup SLIME. + Takes a `autodoc' keyword argument to enable + slime-autodoc-mode. We can add more keywords in future. + (slime-keys): Moved `slime-reindent-defun' from C-M-q to + C-cM-q. This avoids overriding the standard binding of C-M-q to + index-sexp. + (slime-typeout-frame-properties): Removed some properties: + `name', because it interacts badly with X properties, `left' and + `top' because they don't put the frame anywhere terribly + convenient, and (width . 40) because it makes the frame narrower + than the usual word-wrapping width. + +2004-07-14 Peter Seibel peter@javamonkey.com + + * slime.el (slime-lisp-package-prompt-string): Separate SLIME's + notion of package into two parts, an actual package name and the + name used in the prompt since the latter isn't necessarily an + actual package nickname any more. + +2004-07-13 Luke Gorrie luke@bluetail.com + + * slime.el (slime-restart-inferior-lisp): Renamed shortcut to + "restart-inferior-lisp" from "restart-lisp". The name better + suggests what it does: kill *inferior-lisp* and rerun SLIME. + +2004-07-13 Eric Blood eblood@winkywooster.org + + (slime-inspector-next-inspectable-object): New inspector command + to goto the next inspectable object (slot). Bound to TAB. + +2004-07-13 Christophe Rhodes csr21@cam.ac.uk + + * slime.el: add support for actionable references in the + *slime-compiler-notes* buffer. + (slime-merge-notes): merge references if applicable. + (slime-compiler-notes-mode-map): use new functions defaulting to + show-details, but overrideable by text properties. + (slime-tree-default-printer): destroy generality by assuming a + tree of conditions, and insert references if applicable. + (sldb-format-reference-source): add :amop + + * swank-sbcl.lisp (signal-compiler-condition, + brief-compiler-message-for-emacs, + long-compiler-message-for-emacs): handle references in compiler + conditions. + + * swank.lisp (make-compiler-note): propagate references. + + * swank-backend.lisp (compiler-condition): add references slot. + +2004-07-12 Luke Gorrie luke@bluetail.com + + * slime.el (slime-easy-menu): Added "Apropos all" menu item. + (slime-restart-lisp): Added `restart-lisp' shortcut. Doesn't do + the right thing if you have multiple Lisps up. + + * swank.lisp: Added some docstrings. + Rearranged completion code and somewhat SLDB trying to layout + functions above their subfunctions in a tree-like way. + (slime-protocol-error): Renamed from slime-read-error. + (carefully-find-package): Now returns NIL if package can't be + determined, rather than *BUFFER-PACKAGE*. Correct? I didn't see + why it should return *BUFFER-PACKAGE*. + (xref): Find symbol in *BUFFER-PACKAGE*. + +2004-07-09 Peter Seibel peter@javamonkey.com + + * swank.lisp (package-string-for-prompt): Change the way package + name in prompt is computed. N.B. after this change the name + displayed will not necsarily be either an actual name or nickname + of the package: if the name contains dots by default the prompt + will only display the last element, i.e. COM.GIGAMONKEYS.SPAM will + be shown as SPAM. This change also makes CL-USER the canonical + name for COMMON-LISP-USER even in implementations that provide a + shorter nickname such as USER. + +2004-07-09 Christophe Rhodes csr21@cam.ac.uk + + * slime.el (sldb-lookup-reference): substitute hyphens for spaces + in the url. + +2004-07-07 Thomas Schilling tjs_ng@yahoo.de + + * swank.lisp (arglist-for-insertion): Changed formatting to use + arglist-to-string. That results in proper cases for + slime-insert-arglist. + +2004-07-07 Luke Gorrie luke@bluetail.com + + * swank-loader.lisp (*lisp-name*): Include the version number in + ACL. + + * slime.el (slime-alistify): Preserve order. This keeps the + *compiler-notes* right. Pointed out by Christophe Rhodes. + (slime-repl-update-banner-p): Renamed from slime-reply-.. + (slime-changelog-date): Reintroduced for informational purposes. + (slime-repl-update-banner): Show ChangeLog date in the animation. + (slime-space): Do arglist lookup before inserting the + space. Otherwise we get a funky race condition: entering the space + may trigger `first-change-hook', which would send an async + notification to Lisp, which would put us in the 'busy' state and + thus we wouldn't lookup the arglist! Detective work by Edi Weitz. + (sldb-prune-initial-frames): More regexp fudgery :-(. + (read-directory-name): Use `file-name-as-directory' to ensure we + have the trailing / on the directory name. + (byte-compile-warnings): Bye-compile slime-alistify. Its inputs + can be pretty big. + +2004-07-04 Luke Gorrie luke@bluetail.com + + * slime.el, swank-backend.lisp, swank.lisp: Added a new backend + function `buffer-first-change' which is called via Emacs's + `first-change-hook' in slime-mode buffers. This gives Lisp a + chance to do something with source files before you change them on + disk. + + * swank-cmucl.lisp (buffer-first-change): Suck the source file + into the cache unless already present. This is for M-. to increase + the chances of our having a copy of the sources corresponding with + the loaded code. Should help with the case where a user edits and + saves a file (without recompiling it) and then M-.'s for one of + its definitions. + + * swank-allegro.lisp (make-process/inherit): Changed reader + conditionals to use fwrappers for #+(version>= 6). + + * swank-backend.lisp (make-stream-interactive): This backend + function is called with each stream that will be used for + user-interaction, i.e. the redirected stdio streams. Can be used + to setup special output-flushing or similar. + + * swank.lisp (open-streams): Call make-stream-interactive on the + redirected io streams. + + * swank-allegro.lisp (make-stream-interactive): Set + interactive-stream-p slot on the stream to make it auto-flush. + (*swank-thread*, *inherited-bindings*): New variables. + (spawn): Bind *swank-thread* to T. + (make-process/inherit): Fwrapper (advice) for + mp:make-process. When *swank-thread* is T then make the new thread + inherit "sliminess": debugger hook, I/O streams, and also + *swank-thread* so that its children will inherit too. + +2004-07-03 Luke Gorrie luke@bluetail.com + + * hyperspec.el (common-lisp-hyperspec-section-4.0): Bugfix from + Lennart Staflin. + + * slime.el (slime-repl-clear-output): Avoid clearing the previous + REPL expression too. Patch from Andras Simon. + + * swank-backend.lisp (definterface): Don't use + NO-APPLICABLE-METHOD for default methods. Instead just define them + as regular methods with all argument types being + T. Defimplementation will then replace them by using the same + signature. N-A-M was a stupid idea! + +2004-07-02 Brian Downing bdowning@lavos.net + + * slime.el (slime-reindent-defun): Added a check for (boundp + 'slime-repl-input-start-mark) before checking the variable, as + XEmacs leaves variables unbound when `make-variable-buffer-local' + is run, while GNU Emacs binds them to NIL. + +2004-07-02 Martin Simmons martin@xanalys.com + + * swank-lispworks.lisp (dspec-stream-position, + make-dspec-location): Fix typo in features for LW 4.1 and 4.2. + +2004-07-01 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-lispworks.lisp (frame-actual-args): Bind + *break-on-signals* to nil and special case &rest, &optional, and + &key. + +2004-07-01 Luke Gorrie luke@bluetail.com + + * slime.el (sldb-lookup-reference): Preserve case in SBCL node + names. Previously they were downcased, but the HTML manual's + filenames seem to have changed. + + * NEWS: Added security note about the TCP server. + Added notes for ACL and ABCL. + + * doc/slime.texi: General updatings for an alpha release. + +2004-06-30 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-display-compilation-output): New customizable + variable. + + * swank.lisp: Minor cleanups. + (find-symbol-designator, find-symbol-or-lose) + (case-convert-input): Deleted. Replaced with calls to + parse-symbol{-or-lose}. + + * swank-lispworks.lisp (describe-symbol-for-emacs): Include + information about setf-functions. + (emacs-connected): Add a default method to + env-internals:environment-display-debugger. + +2004-06-30 Luke Gorrie luke@bluetail.com + + * slime.el (slime-read-port-and-connect-to-running-swank) + (slime-connect, slime-open-stream-to-lisp): Replace "localhost" + with "127.0.0.1". This is believed to avoid unwanted DNS lookups + on certain operating systems. The lookups can become crippling if + the DNS server isn't available. + (line-beginning-position, line-end-position): Simple bugfix + suggested by Richard Klinda. + + * swank-sbcl.lisp (preferred-communication-style): Choose + :fd-handler instead of :sigio when threads aren't available. A lot + of people seem to have had problems with :sigio on SBCL. + +2004-06-30 Luke Gorrie luke@bluetail.com + + * NEWS: Wrote preliminary release notes for alpha-1. + +2004-06-29 Luke Gorrie luke@bluetail.com + + * mkdist.sh: New shell script for creating a tarball for + distribution. + +2004-06-29 Bill Clementson Bill_Clementson@peoplesoft.com + + * slime.el (slime-who-map): Add extra bindings for the XREF + commands as with the documentation commands. Now `C-c C-w C-c' is + `slime-who-calls' in addition to `C-c C-w c', etc. + +2004-06-29 Luke Gorrie luke@bluetail.com + + * slime.el (sldb-prune-initial-frames): Tweaked regexp for + matching SWANK's own stack frames for effectiveness in SBCL. + (slime-keys): Shadow remaining inf-lisp keys (C-c C-a, C-c C-v) + with a null `slime-nop' command until we put them to a real use. + + * swank.lisp (open-streams): Renamed the restart around reads from + the user-input stream from ABORT to ABORT-READ. Invoking this + restart seems kinda dangerous, so better for 'a' in SLDB not to do + so. + +2004-06-28 Thomas F. Burdick tfb@OCF.Berkeley.EDU + + * swank.lisp (inspector-nth-part): + * slime.el (slime-inspector-copy-down, slime-inspector-mode-map): + Added copy-down command (M-RET) to easily move an object from the + inspector to the repl. + +2004-06-28 Luke Gorrie luke@bluetail.com + + * slime.el (slime-doc-map): New keymap for documentation + commands. These all use the `C-c C-d' prefix, followed by: + a - apropos + p - apropos-package + z - apropos-all + d - describe-symbol + f - describe-function + h - hyperspec lookup + ~ - hyperspec lookup of a format character + The final keystroke is bound both unmodified and with control, so + both `C-c C-d a' and `C-c C-d C-a' will make an apropos + search. The exception is hyperspec-lookup, because it's nice to + leave C-h unbound so that `C-c C-d C-h' will summarise the + documentation bindings. + +2004-06-28 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-allegro.lisp (nth-frame): Skip frames where + frame-visible-p is false. + + * slime.el (slime-buffer-package): Return the cached package if we + can't find something more sensible; this reverts a previous + change. The Lisp side will now fall back to an existing package + if the one supplied by Emacs doesn't exist. Using the cached + version is also necessary for some commands in the apropos buffer. + (sldb-insert-frame): Set the default-action property; pressing RET + on frame lines now shows/hides details. + (sldb-toggle-details): Preserve the current column. + (slime-inspector-buffer, slime-saved-window-config) + (slime-inspector-quit): Save and restore the window configuration. + (slime-highlight-suppressed-forms, slime-search-suppressed-forms): + Display expressions with reader conditionals (#+/#-) in + font-lock-comment-face if the test is false. Not implemented for + XEmacs. + (repl-return): New test. + +2004-06-28 Luke Gorrie luke@bluetail.com + + * slime.el: Events in the *slime-events* buffer are now exact + on-the-wire messages, without including e.g. Elisp continuation + functions. This is easier for debugging I think. + + * swank-allegro.lisp (compute-backtrace): Only include frames + satisfying `debugger:frame-visible-p'. I did this as a lame + workaround for a problem where `output-frame' was segfaulting on + certain frames, and those frames happened not to be visible-p. I + don't know if it really fixes anything. + + * hyperspec.el (common-lisp-hyperspec-format): This command now + works at the end of the buffer, fixed `char-after' usage as + suggested by Johan Bockg�rd. + +2004-06-28 Christophe Rhodes csr21@cam.ac.uk + + * hyperspec.el: add support for issue cross-reference lookups, + strongly inspired by hyperspec symbol lookup. + (common-lisp-hyperspec-issuex-table, + common-lisp-hyperspec-issuex-symbols): new variables + (common-lisp-issuex): new function + + * slime.el (sldb-format-reference-node, sldb-lookup-reference): + (sldb-reference-properties): use new support for issue lookups + to support :ansi-cl :issue reference types. + + * hyperspec.el: add support for glossary lookups. + (common-lisp-glossary-fun): new variable + (common-lisp-glossary-4.0, common-lisp-glossary-6.0): new functions + + * slime.el (sldb-format-reference-node, sldb-lookup-reference): + (sldb-reference-properties): use new support for glossary lookupts + to support :ansi-cl :glossary reference types. + +2004-06-27 Helmut Eller e9626484@stud3.tuwien.ac.at + + * doc/slime.texi: Remove macros from chapter and section headings + to avoid texi2pdf breakage. + + * swank-source-path-parser.lisp (cmucl-style-get-macro-character): + Add tests for #\space and #\. Suggested by Christophe Rhodes. + + * swank-sbcl.lisp, swank-openmcl.lisp, swank-lispworks.lisp, + swank-cmucl.lisp, swank-backend.lisp, swank-allegro.lisp, + swank-abcl.lisp (thread-id, find-thread): New backend functions. + + * swank.lisp (dispatch-event): Quitting from the debugger was + seriously broken. Fix it. Move generation of thread ids to the + backends. + (encode-message, send-to-socket-io): Use WITHOUT-INTERRUPTS in + send-to-socket-io. The multithreaded version of encode-message + doesn't need it. + (nth-thread): Renamed from lookup-thread-by-id. + (debug-nth-thread): Renamed from debug-thread-by-id: + (kill-nth-thread): Renamed from kill-thread-by-id. + + * slime.el (sldb-get-buffer): Add support for sldb buffers for + multiple threads. + +2004-06-25 Thomas F. Burdick tfb@OCF.Berkeley.EDU + + * swank-sbcl.lisp (call-with-syntax-hooks, with-debootstrapping): + Preserve compatability with fairly recent SBCLs by checking for + the presense of the debootstrapping facilities at macroexpansion + time. + + * slime.el (sldb-insert-condition): Initialize sldb-default-action + so that pressing RET inspects the condition. + +2004-06-25 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-repl-insert-prompt): Set defun-prompt-regexp. + beginning-of-defun can be very slow in the repl buffer if the + defun-prompt-regexp is not set. + (sldb-insert-locals): Initialize sldb-default-action. + (sldb-var-number-at-point, sldb-inspect-var): New function. + + * swank.lisp (inspect-frame-var): New function. + + * swank-backend, swank-cmucl.lisp, swank-sbcl.lisp, + swank-allegro.lisp, swank-lispworks.lisp, swank-clisp.lisp + (frame-var-value): New backend function. + +2004-06-24 Christophe Rhodes csr21@cam.ac.uk + + * slime.el (sldb-format-reference-node): fix for when `what' is a + list. + (sldb-lookup-reference,sldb-reference-properties): support + :ansi-cl :section reference types. + + * hyperspec.el (common-lisp-hyperspec-6.0): generalize to work + with section numbers lower than 10. + +2004-06-24 Brian Downing bdowning@lavos.net + + * slime.el (slime-repl-send-input): Fixed a subtle difference in + sending input to the Lisp introduced in 1.316. The newline was + not getting sent, resulting in the Lisp constantly asking for more + read data. I believe the code has been adjusted to behave the + same as 1.315 with regard to sending newlines. + Also adjusted the `slime-repl-old-input' text property to end just + before the newline, not just after. This causes a gap between + inputs even if no Lisp output appeared in between, so that putting + point on an old line and hitting RET will only call up that line, + and hitting RET in the middle of the current line will send it and + not bring up a confusing combination of all previous input. + Many thanks to Loyd Fueston for pinpointing the date and exact + patch for when this problem was introduced. + +2004-06-23 Brian Downing bdowning@lavos.net + + * slime.el: Re-added most of Luke's patches from yesterday. It + has the shortened names, uses markers instead of stored `(point)' + values, and `slime-fuzzy-complete-symbol' is an option for + `slime-complete-symbol-function'. + It still string compares the target buffer instead of using + `(buffer-modified-tick)'. + I left the `C-c M-i' keybinding in, as it allows use of the + regular completion as well. If there's an objection to this it + can be removed. + `window-configuration-change-hook' is used if the variable is + present, and ignored it not. This neatly sidesteps its absence in + XEmacs while not killing the functionality for GNU Emacs. + + * doc/slime.texi: Added a command entry and short description for + `C-c M-I, slime-fuzzy-complete-symbol', and added its existence to + the `slime-complete-symbol-function' documentation. + +2004-06-22 Luke Gorrie luke@bluetail.com + + * doc/slime.texi: Noted ABCL support. + + * slime.el: Backed out all of my changes to fuzzy completion. I + was too hasty and didn't do good things. Now it's back in pristine + state from Brian's patch -- use `C-c M-i' to fuzzy-complete. + + * doc/Makefile (contributors.texi): The contributors list in the + manual is now sorted by most number of ChangeLog entries. Patch + from Michael Weber. + + * slime.el: Some minor hacking to fuzzy completion: + Use the shorter `slime-fuzzy-' symbol prefix. + Use markers instead of numbers to remember where the completion is + being done. This way they are self-updating. + Use `buffer-modified-tick' to detect modifications instead of text + comparison. + Always restore window configuration when a completion is + chosen. For this completion style I think this will work okay + [famous last words], and the existing code wasn't + XEmacs-compatible for want of window-configuration-change-hook. + Now there is no separate keybinding for fuzzy completion, but it's + included as a customize option for `slime-complete-symbol-function' + +2004-06-22 Brian Downing bdowning@lavos.net + + * slime.el, swank.lisp: Added "fuzzy completion." + +2004-06-22 Matthew Danish mdanish@andrew.cmu.edu + + * swank-backend.lisp (unbound-slot-filler): New structure for + representing an unbound slot in the inspector functions. + + * swank.lisp, swank-allegro.lisp: Use it. + +2004-06-22 Luke Gorrie luke@bluetail.com + + * slime.el (slime-output-filter): Choose connection based on + process-buffer, not current buffer. This fixes a bug where output + from multiple Lisp sessions could get mixed up. + (slime-kill-all-buffers): Include all *inferior-lisp*[<n>] buffers. + Split the customize settings into more subgroups. + + * swank.lisp (prefixed-var): Intern *REAL-STANDARD-INPUT* etc in + the SWANK package instead of the COMMON-LISP package. + +2004-06-21 Luke Gorrie luke@bluetail.com + + * swank-loader.lisp (*lisp-name*): Add version number to + Lispwork's fasl directory. We should do this for ACL and OpenMCL + too, but for some reason my ACL 5.0 gets an error when trying to + create a directory with a version number in its name, and I don't + have OpenMCL to test with. + + * swank-backend.lisp, swank.lisp (add-hook, run-hook): Moved the + hook mechanism and all hooks to swank.lisp (from + swank-backend.lisp). There is no compelling use for the hooks in + backends yet and I want to pass swank.lisp-internal data + structures in the existing hooks. + (notify-backend-of-connection): Call `emacs-connected' with the + user-io stream for its argument. Should fix previous breakage + where the connection structure was passed instead. + (*globally-redirect-io*): New configurable: when true the standard + streams are globally redirected to Emacs. That way even + e.g. SERVE-EVENT handlers will print to Emacs. Currently does not + handle standard input -- that is trickier since the Lisp's native + REPL can be trying to read from that. + + * slime.el (slime-complete-maybe-restore-window-configuration): + Only restore the window configuration if the completions buffer is + currently visible in the window that we popped it up in. + (slime-complete-maybe-save-window-configuration): Don't save the + window configuration if the completions buffer is already visible. + (slime-repl-return): Make sure the newline goes at the end of the + input, not at point. + (slime-complete-restore-window-configuration): Wrap the + `set-window-configuration' call in (run-at-time 0 ..). XEmacs does + not allow us to set the window configuration from inside + pre-command-hook. + +2004-06-20 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-sbcl.lisp (emacs-connected): Set *invoke-debugger-hook* to + our debugger hook. Not optimal, but at least BREAK will then + invoke our debugger. + (*trap-load-time-warnings*): New variable. If it is true, + conditions, most notably redefinition warnings, signalled at load + time are not trapped. + (swank-compile-file, swank-compile-string): Use it. + + * swank.lisp (guess-buffer-package): Don't signal a continuable + error if the package doesn't exists; that's too annoying. + + * slime.el: Fix outline structure. + (slime-maybe-list-compiler-notes): Fix thinko. + (break): New test. Reorganize the test-suite a bit to support + "expected failures". + (slime-eval-feature-conditional, slime-to-feature-keyword): Add a + ?: to the symbol-name if needed. + +2004-06-20 Luke Gorrie luke@bluetail.com + + * swank.lisp (changelog-date): Removed unneeded function. + (connection-info): No more version field in result. + + * slime.el: Audited to remove namespace slipups. Tracking a really + horrible clashing-with-some-user-configuration bug and want to + eliminate potential symbol conflicts. + (sldb-get-buffer): Renamed from `get-sldb-buffer'. + (slime-emacs-20-p): Renamed from `emacs-20-p'. + (slime-defun-if-undefined): Renamed from `defun-if-undefined'. + (slime-isearch): Small bugfix that could cause M-. to go to the + wrong place in CMUCL. + (slime-changelog-date, slime-check-protocol-version): Removed + unneeded functions. + + * swank-backend.lisp (add-hook, run-hook): Added an Emacs-like + hook mechanism. The hope is that this will make some sections of + the code more self-describing by showing where they hook in. + (*new-connection-hook*): Hook run when a new connection is + established. Initialized to '(swank-backend:emacs-connected). + (*pre-reply-hook*): Hook run before sending a reply to Emacs. + + * swank.lisp: Added some comments and docstrings. + (package-external-symbols): Removed unused function. + (serve-connection): Call *new-connection-hook*. + (eval-for-emacs): Call *pre-reply-hook*. + (sync-features-to-emacs, sync-indentation-to-emacs): Added to + *pre-reply-hook*. + (cl-package, keyword-package): Now defconstant instead of + defvar. Removed the *'s accordingly. + + * slime.el (slime-abort-connection): Renamed from + `slime-connection-abort'. The new name is easier to find with + completion. + + * swank-sbcl.lisp: Change sb-posix:: to sb-posix: + +2004-06-19 Luke Gorrie luke@bluetail.com + + * swank.lisp (known-to-emacs-p): Bugfix. Indentation-updates was + broken. + +2004-06-18 Luke Gorrie luke@bluetail.com + + * slime.el (slime-buffer-package): If DONT-CACHE is true and no + package name can be found, then default to "COMMON-LISP-USER." + Previously we just kept using the cached version, but that could + lead to error-after-error if it was incorrect. + + * swank.lisp (throw-to-toplevel): If our top-level catcher isn't + on the stack (i.e. we're using the debugger from outside an RPC) + then ABORT instead. That makes 'q' DWIM in SLDB. + +2004-06-18 Matthew Danish mdanish@andrew.cmu.edu + + * swank-allegro.lisp (frame-source-location-for-emacs): + Implemented. + +2004-06-18 Luke Gorrie luke@bluetail.com + + * slime.el (slime-repl-return): If the user presses return on old + REPL input then take it and insert it as the current input. + Signal an error if the point is not on any input. + (slime-preserve-zmacs-region): Function to ensure that the current + command doesn't deactivate zmacs-region (XEmacs only). + (slime-repl-bol, slime-repl-eol): Use it. + (slime-kill-all-buffers): Changed buffer-name regexps for XEmacs + compatibility. The ",quit" shortcut now works in XEmacs. + (slime-display-message): Fixed call to `slime-typeout-message' + to handle formatting characters. Avoids errors on certain messages. + (slime-list-compiler-notes): Save the window configuration + earlier. This fixes an error under XEmacs when dismissing the + notes buffer. + (slime-recenter-window): Avoid moving the point. This keeps the + point in the right place when showing debugger-frame locations in + Emacs 21. + +2004-06-17 Luke Gorrie luke@bluetail.com + + * swank-loader.lisp (binary-pathname): Place fasl files under + ~/.slime/fasl/ instead of the SLIME installation directory. The + installation directory can now be read-only. + (binary-pathname, user-init-file): Removed Win32 + conditionalization. The init file is now called ~/.swank.lisp + instead of ~/_swank.lsp. + + * swank-lispworks.lisp (with-fairly-standard-io-syntax): New + macro. Like with-standard-io-syntax, but keeps the existing values + of *package* and *readtable*. + (dspec-stream-position): Use it. + (quit-lisp): Implemented. + +2004-06-16 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-set-default-directory): Don't call + slime-repl-update-banner in Emacs 20. + (slime-show-source-location, slime-recenter-window): Use + set-window-start instead of recenter; this avoids flickering. + (sldb-list-locals): Don't forget about slime-current-thread in the + temporary buffer. (Fixes bug reported by Mike Beedle.) + (sldb-step): Re-enabled. The CMUCL backend has rudimentary support + for stepping. + + * swank.lisp (*readtable-alist*): Call backend function for + initialization. + (eval-for-emacs, guess-buffer-package): Signal a continuable error + if a package name was supplied but no such package exists. Not + sure if this is better than what we did before (i.e. silently use + the current package). + + * swank-cmucl.lisp (default-directory): Add implementation. + (sldb-step): Uncomment it and remove references to + *swank-debugger-condition*. + + * swank-backend.lisp (sldb-step, default-readtable-alist): New + backend functions. + (emacs-connected): Pass the redirected stream as argument, so that + the OpenMCL backend can add it to CCL::*AUTO-FLUSH-STREAMS*. + + * swank-sbcl.lisp (default-readtable-alist): Implement it. + + * swank-loader.lisp: Move readtable-alist initialization to + swank-sbcl.lisp. + + * swank-allegro.lisp (default-directory, call-with-syntax-hooks): + Add implementations as workarounds for ACL5 bugs. + +2004-06-16 Lawrence Mitchell wence@gmx.li + + * slime.el (slime-maybe-rearrange-inferior-lisp): Call + `generate-new-buffer-name' manually, rather than relying on the + UNIQUE argument to `rename-buffer' to do so. + +2004-06-16 Frederic Brunel frederic.brunel@in-fusio.com + + * slime.el (slime-startup-animation): Use defcustom to declare the + variable. + (slime-enable-startup-animation-p): Deleted. + +2004-06-16 Robert Lehr bozzio@the-lehrs.com + + * slime.el (slime-backend): This variable can now be set to an + absolute filename. + +2004-06-15 Luke Gorrie luke@bluetail.com + + * slime.el (slime-compile-file): Just prompt for saving the + current file instead of calling `save-some-buffers'. Based on a + patch from Brian Downing. + +2004-06-12 Helmut Eller e9626484@stud3.tuwien.ac.at + + * wank-allegro.lisp (format-sldb-condition, condition-references): + Add workarounds for buggy no-applicable-method. + + * swank.lisp (parse-symbol, parse-package): Handle reader errors. + + * swank-openmcl.lisp (send, receive): Ensure that messages are + never nil. + +2004-06-10 Christophe Rhodes csr21@cam.ac.uk + + * swank-sbcl.lisp (call-with-syntax-hooks): Add hooks to fix + "SB!"-style package names. + (shebang-readtable): Return a readtable with readermacros needed + to parse SBCL sources. + + * swank.lisp (with-buffer-syntax): New macro. This should be used + for code which needs to READ code from Emacs buffers. *package* + and *readtable* are bound suitable values. + (to-string, format-values-for-echo-area, interactive-eval) + (eval-region, interactive-eval-region, re-evaluate-defvar) + (swank-pprint, pprint-eval, listener-eval) + (compile-string-for-emacs, disassemble-symbol, describe-to-string) + (describe-symbol, describe-function) + (describe-definition-for-emacs) + (documentation-symbol, init-inspector, inspect-nth-part) + (inspector-pop, inspector-next, describe-inspectee) + (inspect-current-condition): Use it. + +2004-06-10 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-loader.lisp: Initialize swank::*readtable-alist* for SBCL. + + * swank-backend.lisp (default-directory, call-with-syntax-hooks): + New functions. + + * swank.lisp (*readtable-alist*): New configurable. The keys are + package name and the values readtables. The readtable will be + used to READ code originating from Emacs buffers in the associated + slime-buffer-package. + (drop-thread): Simplified. + (*buffer-readtable*): New variable. + (parse-package): New function. + (parse-string): Renamed from symbol-from-string. Make it case + insensitive. + (eval-for-emacs): Initialize the *buffer-readtable*. + (symbol-indentation): Don't consider symbols in the CL package. + Emacs already knows how to indent them. + (compile-file-if-needed): Used for REPL shortcut + 'compile-and-load'. + + * slime.el (pwd): Re-add REPL shortcut. + (slime-repl-push-directory, slime-repl-compile-and-load): Simplified. + +2004-06-10 Luke Gorrie luke@bluetail.com + + * slime.el (sldb-step): Command is disabled because the function + `swank:sldb-step' that it calls doesn't exist. I don't see any + stepping code in our backends. + +2004-06-09 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-goto-location-position) [:function-name]: The + function name can also occur after a ?(, not only after + whitespace. + + * (slime-init-output-buffer): Initialize the package stack. + Reported by Rui Patroc�nio. + + * (slime-completions): Make it consistent with + slime-simple-completions. The second argument was never supplied. + Reported by Rui Patroc�nio. + +2004-06-09 Eric Blood eblood@winkywooster.org + + * slime.el (slime-indent-and-complete-symbol): Renamed from + slime-repl-indent-and-complete-symbol. + + (slime-typeout-frame-properties): Add more default options for the + typeout frame--specifically it now has a default width, and moves + the typeout frame to the upper right. + +2004-06-09 Andras Simon andras@renyi.hu + + * swank-abcl.lisp: New backend for Armed Bear Common Lisp. + + * swank-loader.lisp: Add ABCL support. + +2004-06-09 Martin Simmons martin@xanalys.com + + * swank-lispworks.lisp (dspec-stream-position): New function to + make source location work for anything complicated e.g. methods. + (with-swank-compilation-unit): Refactoring. + (who-macroexpands): Implemented. + (list-callers): Implemented. + + * swank-backend.lisp (network-error): Inherit from simple-error to + get correct initargs. + +2004-06-09 Luke Gorrie luke@bluetail.com + + * slime.el (sldb-insert-references): Added support for hyperlinked + references as part of conditions being debugged. This is a new + feature in SBCL to reference appropriate sections of their manual + or CLHS from condition objects. The references are clickable. + + * swank-backend.lisp (format-sldb-condition): New backend function + to format conditions for SLDB. + (condition-references): New function to return a list of + documentation references associated with a condition. + + * swank.lisp (debugger-condition-for-emacs): Call the above + backend functions to add a `references' list for Emacs. + + * swank-sbcl.lisp (format-sldb-condition, condition-references): + Implemented. Requires a recent (latest?) SBCL release. + +2004-06-08 Luke Gorrie luke@bluetail.com + + * swank-cmucl.lisp (close-socket): Remove any SERVE-EVENT handlers + for the socket's file descriptor. + + * swank-sbcl.lisp (close-socket): Same fix. + +2004-06-07 Luke Gorrie luke@bluetail.com + + * swank-cmucl.lisp: Minor refactorings. + +2004-06-07 Edi Weitz edi@agharta.de + + * swank-allegro.lisp (call-with-compilation-hooks): Implemented. + Wrap IMPORT call in EVAL-WHEN. + + * swank.lisp, swank-backend.lisp: Wrap EXPORT calls in + EVAL-WHEN. Fixes many warnings in ACL. + +2004-05-25 Luke Gorrie luke@bluetail.com + + * slime.el (slime-kill-without-query-p): Default to T. + (sldb-highlight): Variable to control face-based highlighting of + SLDB locations. (In Emacs21 the point is visible even in unselected + windows, which is sufficient for me.) + (sldb-show-location-recenter-arg): Argument to `recenter' when + showing SLDB locations. Default to nil, i.e. location appears in + the middle of the window. + +2004-05-24 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-input-complete-p): Return nil for unbalanced + sexps starting with quote ?', backquote ?`, or hash ?#. C-j can + be used for more complicated cases. + +2004-05-22 Marco Baringer mb@bese.it + + * slime.el (slime-repl-sayoonara): Added "quit" as an alias for + sayoonara. + +2004-05-22 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp (arglist): Catch (reader) errors in + READ-ARGLIST. + + * swank-allegro.lisp (fspec-primary-name): New function. + (find-fspec-location): Use it, if the start position cannot be + found. + + * slime.el (slime-pprint-event): New function. + (slime-log-event): Use it. + (slime-reindent-defun): Indent the form after point, if point is + in the first column an immediately before a #(. + +2004-05-21 Bill Clementson Bill_Clementson@peoplesoft.com + + * slime.el (slime-switch-to-output-buffer): Use "P" as interactive + spec. + +2004-05-21 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-switch-to-output-buffer): Override the + prefix-arg if we are called non-interactively. + (slime-repl-current-input): Don't add newlines. + (slime-repl-return): Send input if we are in read-mode also if it + isn't a complete expression. + (repl-read-lines): New test case. + (slime-enable-startup-animation-p): New configurable. + (slime-repl-update-banner): Use it. + (slime-hide-inferior-lisp-buffer): New function. Reuse the + *inferior-lisp* buffer window for the SLIME REPL. + + * swank-allegro.lisp (find-fspec-location): Better handling of + methods. From Bill Clementson. + +2004-05-17 Luke Gorrie luke@bluetail.com + + * xref.lisp, swank-clisp.lisp: Renamed XREF package to PXREF (P + for portable). This makes it possible to load the package in + e.g. CMUCL, which is nice because it's a good package. + + * swank-cmucl.lisp: Some refactoring and high-level + commenting. Mostly just trying to organise things into fairly + self-contained sections (my new hobby, sad I know!) + + * slime.el: Added `C-c C-e' as an alternative binding for + `slime-interactive-eval' (usually `C-c :'). This seems slightly + more convenient, and has the added bonus of clobbering an unwanted + `inf-lisp' binding. + +2004-05-14 Marco Baringer mb@bese.it + + * slime.el (slime-with-output-to-temp-buffer): Now takes a + package arg specifying what slime-buffer-package should be in the + generated buffer. + (slime-show-description): actually pass the package arg. + (slime-show-apropos): pass the package arg to + slime-with-output-to-temp-buffer. + (slime-list-repl-shortcuts): pass a package arg. + +2004-05-12 Alan Ruttenberg alanr-l@mumble.net + * swank-openmcl.lisp: Fixes to support openmcl 0.14.2 changes in + backtrace protocol, from Gary Byers. + - Replace string "tcr" to "context". + - Change the call to %current-tcr in map-backtrace to get-backtrace-context, + defined so as to be back compatible with 0.14.1. + - Change the call to %catch-top to explicitly use %current-tcr + instead of the passed in tcr-which-is-now-called-context. + + Users of map-backtrace (outside of slime code) note: The tcr position in the + function call is now occupied by the backtrace "context" which is always nil. + If you really need the tcr then you need to call %current-tcr yourself now. + + Gary comments: The part that's a little hard to document about + the new "context" stuff - used to walk the stacks of thread A from + thread B - is that thread B has to be aware of when a context + becomes invalid (a context describing part of thread A's stack is + valid while thread A's sitting in a break loop and becomes invalid + as soon as it exits that break loop.) A thread sort of announces + when a context becomes valid and when it becomes invalid; whether + and how SWANK could hook into that isn't yet clear. + + * swank-openmcl.lisp: Minor changes to backtrace display: Anonymous + functions names in function position surrounded by #<>. Use prin1 instead of + princ to print function arguments (so strings have "s around them). + prefix symbol and list arguments by "'" to make them more look like a + valid function call. Let me know if you don't like this... + +2004-05-12 Luke Gorrie luke@bluetail.com + + * slime.el: Fixes for outline-mode in *slime-events* from Edi + Weitz. + +2004-05-11 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-events-buffer): Disable outline-mode by default. + (slime-inhibit-ouline-mode-in-events-buffer): New variable. + (slime-expected-failures): Reduce the number for SBCL. + + * swank-sbcl.lisp (resolve-note-location): Resolve the location if + we are called by swank-compile-string. The pathname argument is + never :stream in SBCL, so the method written for CMUCL was never + called. + +2004-05-10 Luke Gorrie luke@bluetail.com + + * swank.lisp (from-string): Bind *READ-SUPPRESS* to NIL. + (swank-compiler): Bind a restart to abort compilation but still + report the compiler messages already trapped. + (string-to-package-designator): Function that uses READ to + case-convert package names. + (apropos-list-for-emacs): Use it. + + * slime.el (slime-eval-with-transcript): Don't print the "=>" + prefix in messages showing evaluation results. It mucks up + alignment in multi-line messages. + (sldb-eval-in-frame): Don't print "==>" prefix on evaluation + results, for the same reason. + (slime-show-source-location): Move the point to the source + location in addition to highlighting the matching parens. + +2004-05-08 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp (find-definitions): Add support for variables + and constants. + +2004-05-07 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-clisp.lisp (compiler-note-location): Use make-location to + instead of `(:location ...). This initializes the new hint slot + automatically. + +2004-05-07 Barry Fishman barry_fishman@att.net + + * swank.lisp (prin1-to-string-for-emacs, arglist-to-string): CVS + CLISP prints NIL as |COMMON-LISP|::|NIL| if *print-readably* is + true. Set *print-readably* to nil for a more Emacs friendly + printer syntax. + +2004-05-06 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-maybe-list-compiler-notes): Display the notes + listing after C-c C-c only if there are no annotations in the + buffer. CMUCL creates usually one warning with an error location + and an almost redundant warning without at the end of the + compilation unit. Don't display the listing in this common case. + + (slime-reindent-defun): Pass nil as the third arument to + indent-region. + +2004-05-06 Marco Baringer mb@bese.it + + * slime.el (slime-repl-sayoonara): Don't attempt to quit the lisp + if we're not connected. + + * swank-openmcl.lisp (*buffer-offset*, *buffer-name*): Supply + default values. This avoids unbound value errors when compiling an + asdf system signals errors. + +2004-05-04 Alan Shutko ats@acm.org + + * slime.el (slime-compiler-notes-show-details/mouse): New command. + (slime-compiler-notes-mode-map): Use it. + +2004-05-04 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp (arglist): Handle byte-code functions better. + We don't know much about the actual argument list, only the number + of arguments. Return at least something mildly interesting like + (arg0 arg1 &optional arg2 ...) + (function-location): Special-case byte-code functions. + + * swank-backend.lisp (with-struct): New macro. + +2004-05-04 Thomas F. Burdick tfb@OCF.Berkeley.EDU + + * slime.el (slime-reindent-defun): New command on C-M-q. Reindent + the current Lisp defun after trying to close any unmatched + parenthesis. If used within a comment it just calls fill-paragraph. + +2004-05-04 Luke Gorrie luke@bluetail.com + + * slime.el (slime-goto-location-position): Regexp fix. + (slime-reindent-defun): New command on M-q. Reindent the current + Lisp defun after trying to close any unmatched parenthesis. + + * swank.lisp: Remove (declaim (optimize ...)). The side-effect + this has on people's environment seems harmful (I saw someone + having trouble on the OpenMCL list). + + * swank-cmucl.lisp (source-location-from-code-location): Fixed a + bug where the source-file-cache was not really used. + Now always report the location based on source file (cached or + not) even if modified -- not falling back on regexps, which was + probably a misfeature. + + * slime.el: Remove `slime-cleanup-definition-refs'. + +2004-05-02 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-start-and-load): New command. Suggested by + Lars Magne Ingebrigtsen. + +2004-05-02 Lars Magne Ingebrigtsen larsi@netfonds.no + + * slime.el (slime-kill-without-query-p): New variable. + (slime-net-connect): Use it. + (slime-open-stream-to-lisp): Ditto. + (slime-maybe-start-lisp): Ditto. + +2004-05-02 Luke Gorrie luke@bluetail.com + + * slime.el (slime-goto-source-location): Added support for the + :snippet "hint" in a location specifier. If Lisp sends the + (initial) source text for the definition then Emacs isearches for + it in both directions from the given character position. This + makes M-. robust when the Emacs buffer has been edited. Requires + backends to provide this snippet information. + (slime-goto-location-position): Tightened up the regular + expressions for :function-name style location search. + (slime-cleanup-definition-refs): New function to do a little + post-processing on definition references from Lisp. Mostly this is + a hack: if POSITION is NIL then we fill it in with the function + name, ready for regexp search. I was in a hurry and it was easier + to do here, and it doesn't seem entirely unreasonable. + + * swank-backend.lisp (:location): Added a 'hints' property list + to the location structure. This is for extra information that + compliments the buffer/position. + + * swank-cmucl.lisp (code-location-stream-position): Position the + argument stream at the definition before returning. + (source-location-from-code-location): Include the :snippet hint + for Emacs (see above). The snippet will only be accurate provided + that the source file on disk has not been modified. + (*source-file-cache*) The contents of all source files consulted + for M-. are now cached if they match the version of the running + code. This is so that we can accurately lookup source locations + even when the file is modified, provided we manage to get the + right version (by file timestamp) at least once. + (source-location-from-code-location): If the right source version + is not available on disk or in our cache then let Emacs fall back + on a regular expression search. + +2004-05-01 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-lispworks.lisp (find-top-frame): New function used to hide + debugger-internal frames. + (call-with-debugging-environment): Use it. + +2004-05-01 Luke Gorrie luke@bluetail.com + + * slime.el (sldb-abort): Print a message if the Emacs RPC + returns. It shouldn't, if ABORT manages to unwind the stack, but + it currently does in OpenMCL due to some bug. + (slime-edit-definition-fallback-function): Name of a function to + try if the builtin edit-definition finding fails. You can set + this to `find-tag' to fall back on TAGS. + + * swank.lisp (list-all-systems-in-central-registry): Use explicit + :wild in pathname for matching (needed in at least SBCL). + + * swank-openmcl.lisp: Removed obsolete `swank-compile-system'. + + * swank-sbcl.lisp: Removed obsolete `swank-compile-system'. + Removed some stale comments about supported features. + +2004-04-30 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-repl-update-banner): Don't print the working + directory. It rarely fits in a line and was only Emacs' + default-directory. M-x pwd is convenient enough. + + * swank.lisp (symbol-indentation): Don't infer indentation for + symbols starting with 'def' or 'with-'. It was wrong most of the + time and Emacs' defaults are better. + + * swank-lispworks.lisp (emacs-connected): Add methods to + stream-soft-force-output for socket-streams and + slime-output-streams. This flushes those streams automatically + (i assume it gets called when Lisp is idle). + +2004-04-29 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-repl-mode): Set slime-current-thread to + :repl-thread. + + * swank.lisp (thread-for-evaluation, dispatch-event): Accept + :repl-thread as thread specifier and dispatch evaluation and + interrupt request properly. + (repl-thread-eval, repl-eval): Deleted. We do the special casing in + thread-for-evaluation. + +2004-04-29 Lars Magne Ingebrigtsen larsi@netfonds.no + + * slime.el (slime-event-buffer-name): New variable. + (slime-events-buffer): Use it. + (slime-space-information-p): Ditto. + (slime-space): Use it. + (slime-reply-update-banner-p): Ditto. + (slime-repl-update-banner): Use it. + +2004-04-28 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-loader.lisp (*lisp-name*): Add versioning support for + CLISP. + + * swank-clisp.lisp (arglist): Trap exceptions and return + :not-available in that case. + + * swank.lisp (arglist-for-insertion): Don't use ~< ..~:@>. + CLISP's pretty printer can't handle it. + +2004-04-28 Luke Gorrie luke@bluetail.com + + * NEWS: Created a NEWS file for recording changes that we want + users to read about. + + * slime.el (slime-log-event): Use outline-minor-mode in + *slime-events* instead of hideshow-mode. It's more + reliable. (Patch from Lawrence Mitchell.) + +2004-04-28 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-net-connect): Bind inhibit-quit to nil, so that + we have a chance to interrupt Emacs if open-network-stream blocks. + (slime-complete-maybe-restore-window-configuration): Keep trying + after slime-repl-indent-and-complete-symbol. + (slime-space): Don't close the completion buffer. We don't know + the window-config before the completion, so leave the buffer open. + + * swank.lisp (create-server): New keyword based variant to start + the server in background. + (setup-server): Add support to keep the socket open for + single-threaded Lisps. + +2004-04-27 Luke Gorrie luke@bluetail.com + + * doc/slime.texi (Other configurables): Updated instructions on + globally installing SLDB on *debugger-hook*. + + * slime.el (slime-log-event): Better bug-avoidance with + hs-minor-mode. Hopefully XEmacs users can rest safely now. + (slime-prin1-to-string): Bind `print-escape-newlines' to nil. + (slime-set-connection-info): Commented out call to + `slime-check-protocol-version'. Let's see how we do without it. + (slime-oneway-eval): Removed unused function. + + * swank.lisp (oneway-eval-string): Removed unused function. + +2004-04-26 Luke Gorrie luke@bluetail.com + + * swank.lisp: Move definition of `with-io-redirection' above + `with-connection' to avoid a CLISP error. This is really weird. + (interactive-eval): Bind *package* to *buffer-package*, so that + `C-x C-e' and related commands evaluate in the expected package. + + * slime.el (sldb-insert-frames): Handle empty backtrace (I got one + in CLISP). + + * swank-allegro.lisp (arglist): Return :not-available if arglist + lookup fails with an error. + + * slime.el: Moved snippets of Common Lisp code into swank.lisp + from the thread control panel. (Remember, no CL code in slime.el!) + + * swank-loader.lisp (*lisp-name*): Include a short version number + in the Lisp name to separate FASL files for different + versions. Only implemented for CMUCL and SBCL sofar. + + * swank.lisp (ed-in-emacs): Avoid mutating the argument. + (spawn-repl-thread): Add a new thread for evaluating REPL + expressions. This same thread is used for all REPL + evaluation. This fixes some issues with variables like * and ** + in at least SBCL. + + * nregex.lisp: Typo fix (thanks Barry Fishman). + + * slime.el (slime-events-buffer): Don't use hideshow-mode in + XEmacs for the *slime-events* buffer. It causes obscure problems + for some users. Still used in GNU Emacs. + +2004-04-25 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-backend.lisp (arglist): Return a list or :not-available. + Don't return strings or raise exceptions. + + * swank.lisp (arglist-for-echo-area): Simplified and adapted for + the new semantic of ARGLIST. + (arglist-for-insertion): Now a separate function. + (read-arglist): Deleted. No longer needed. + + * swank-cmucl.lisp, swank-lispworks.lisp (arglist): Return + :not-available if the arglist cannot be determined. + + * slime.el (slime-set-connection-info): Hide the *inferior-lisp* + buffer here, so that we have all the buffer rearrangement in one + place. + (slime-insert-arglist): Use swank:arglist-for-insertion. + +2004-04-24 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-init-connection-state): Use an asynchronous RPC + instead of slime-eval to reduce the amount of work we do in the + timer function. We can remove the workaround for the timer + problem. + +2004-04-23 Luke Gorrie luke@bluetail.com + + * slime.el: Updated top comments. + Make SLIME faces inherit from their font-lock cousins properly. + (slime-connect): Bind `slime-dispatching-connection' to avoid + being confused by old buffer-local variables when initializing + the connection. This fixes a bug where doing `M-x slime' from the + REPL could give a "Not connected" error. + +2004-04-22 Edi Weitz edi@agharta.de + + * slime.el (slime-read-system-name): Perform completion on all + systems in the central registry. + + * swank.lisp (list-all-systems-in-central-registry): New function. + +2004-04-22 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-repl-update-banner): Add workaround to force the + proper behavior of the the first command in the REPL buffer. + (slime-repl-shortcut-history): Define the variable to make XEmacs + happy. + +2004-04-22 Tiago Maduro-Dias tcmd@rnl.ist.utl.pt + + * slime.el (slime-space): Cleanup. + (slime-complete-restore-window-configuration): Use + slime-close-buffer instead of bury-buffer. + +2004-04-21 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: Suppress byte-compiler warnings by binding + byte-compiler-warnings to nil. + (slime-repl-shortcut): Use a structure instead of a list for the + short cut info. Update the users accordingly. + + * swank-cmucl.lisp (arglist): Return a list instead of the string. + +2004-04-21 Edi Weitz edi@agharta.de + + * slime.el (slime-apropos): Add support for regexp-based apropos. + We use nregex, so the regexp syntax is different from Emacs' + regexps and bit restricted (alternation '|' and optional groups + '(xy)?' are not implemented). + (slime-insert-arglist): New command - stolen from ILISP. I always + thought this was quite useful. + (slime-oos): Fix typo. + + * swank.lisp (apropos-symbols): Use regexp and support + case-sensitive matching. + (arglist-for-echo-area): New argument to control if the operator + name should be included. + + * nregex.lisp: New file. + + * swank-loader.lisp (*sysdep-pathnames*): Load it. + +2004-04-21 Helmut Eller e9626484@stud3.tuwien.ac.at + + * doc/slime.texi (Compilation): slime-remove-notes is bound to C-c + M-c not M-c. Noted by Edi Weitz. + +2004-04-21 Edi Weitz edi@agharta.de + + * swank.lisp (list-all-package-names): Optionally include + nicknames in the result. + + * slime.el (slime-read-package-name): Include nicknames in the + completions set. + (slime-repl-mode-map): Bind C-c : to slime-interactive-eval just + like in most other SLIME buffers. + (read-directory-name): Compatibilty defun. + +2004-04-20 Tiago Maduro-Dias tcmd@rnl.ist.utl.pt + + * slime.el (slime-close-buffer): New utility function. + (slime-space): Use it to kill superfluous *Completions* buffers. + +2004-04-17 Raymond Toy rtoy@earthlink.net + + * swank-cmucl.lisp (source-location-tlf-number) + (source-location-form-number): New functions to extract the + encoded form-numbers from source locations. + (resolve-stream-source-location, resolve-file-source-location): + Use them. + +2004-04-17 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-merge-notes): Use mapconcat instead of + (concat (slime-intersperse (mapcar ....))) + (slime-intersperse): Handle empty lists. + +2004-04-16 Luke Gorrie luke@bluetail.com + + * doc/Makefile: Added 'install' and 'uninstall' targets for the + Info manual. It may be necessary to tweak `infodir' in the + Makefile to suit the local system before installing. (Patch from + from Richard M Kreuter.) + + * doc/slime.texi (Top): The Top node is now smaller, with details + moved into Introduction. This makes the Info front page easier to + navigate. (Patch from Richard M Kreuter.) + +2004-04-15 Ivan Boldyrev email@secret-by-request + + * slime.el (slime-handle-repl-shortcut): Call `completing-read' + with an alist as expected, using `slime-bogus-completion-alist'. + +2004-04-14 Luke Gorrie luke@bluetail.com + + * doc/slime.texi (Shortcuts): Described REPL shortcuts. + + * slime.el (slime-oos): Generic ASDF interface. + (force-compile-system, compile-system, load-system, + force-load-system): New REPL commands. + + * swank-backend.lisp (operate-on-system): More generic interface + to ASDF. + + * swank.lisp (operate-on-system-for-emacs): More generic + interface to ASDF. + + * slime.el (slime-repl-mode-map): Portability fix for definition + of the REPL command character. + (slime-maybe-rearrange-inferior-lisp): Bugfix for running + multiple inferior lisps. + +2004-04-13 Marco Baringer mb@bese.it + + * slime.el (slime-handle-repl-shortcut, + slime-list-all-repl-shortcuts, slime-lookup-shortcut, + defslime-repl-shortcut): Refactor repl shortcut code to provide a + more leggible help. + +2004-04-09 Lawrence Mitchell wence@gmx.li + + * slime.el (slime-same-line-p): Use `line-end-position', rather + than searching for a newline manually. + (slime-repl-defparameter): Use VALUE, not VALUE-FORM. + +2004-04-08 Marco Baringer mb@bese.it + + * slime.el (slime-repl-package-stack): New buffer local variable. + (slime-repl-directory-stack): New buffer local variable. + (slime-repl-command-input-complete-p): Remove. + (slime-repl-update-banner): New function. + (slime-init-output-buffer): Use slime-repl-update-banner. + (slime-repl-shortcut-dispatch-char): New variable. + (slime-repl-return): Don't check for repl commands anymore. + (slime-repl-send-repl-command): Remove. + (slime-repl-mode-map): Bind slime-repl-shortcut-dispatch-char to + slime-handle-repl-shortcut. + (slime-set-default-directory): Use read-directory-name, call + slime-repl-update-banner. + (slime-repl-shortcut-table): New global variable. + (slime-handle-repl-shortcut): New function. + (defslime-repl-shortcut): New macro for defining repl shortcuts. + (slime-repl-shortcut-help, "change-directory", + slime-repl-push-directory, slime-repl-pop-directory, + "change-package", slime-repl-push-package, slime-repl-pop-package, + slime-repl-resend, slime-repl-sayoonara, slime-repl-defparameter, + slime-repl-compile-and-load): New repl shortcuts. + (slime-kill-all-buffers): Kill sldb buffers as well. + + * swank.lisp: Remove the repl related functions. + (requires-compile-p): New function. + +2004-04-07 Lawrence Mitchell wence@gmx.li + + * slime.el (slime-repl-prompt-face): New face. + (slime-repl-insert-prompt): Use it. + (slime-with-chosen-connection, with-struct): Docstring + fix for function's arglist display. + (when-let, slime-with-chosen-connection, with-struct): Docstring + fix for function's arglist display. + (slime-read-package-name): Use `slime-bogus-completion-alist' to + construct completion table. + (slime-maybe-rearrange-inferior-lisp): Use `rename-buffer's + optional argument to rename uniquely. + (slime-check-connected): Display keybinding for `slime' via + `substitute-command-keys'. + (slime-repl-send-repl-command): Use whitespace character class in + regexp. + (slime-autodoc-stop-timer): New function. + (slime-autodoc-mode): Add `interactive' spec to specify optional + arg. This allows prefix toggling of mode (behaves more like + most Emacs modes now). Stop timer if switching mode off with + `slime-autodoc-stop-timer'. + (slime-autodoc-start-timer, slime-complete-symbol) + (slime-complete-saved-window-configuration) + (slime-insert-balanced-comments): Docstring fix. + (slime-ed): Call `slime-from-lisp-filename' on filename for list + case of argument. + (slime-insert-transcript-delimiter, slime-thread-insert): Use + ?\040 to indicate SPC. + (line-beginning-position): `forward-line' always puts us in + column 0. + (line-end-position): Define if not fboundp (for older XEmacs). + +2004-04-07 Peter Seibel peter@javamonkey.com + + * swank-allegro.lisp (set-default-directory): Allegro specific + version that also uses excl:chdir. + + * swank.lisp (swank-pprint): Add swank versions of two missing + pretty-printer control variables. + +2004-04-07 Luke Gorrie luke@bluetail.com + + * swank.lisp (completion-set): Also complete package + names. (Patch from Sean O'Rourke.) + (find-matching-packages): Add a ":" to the end of package names + in completion. + +2004-04-06 Luke Gorrie luke@bluetail.com + + * slime.el (slime-bytecode-stale-p): Automatically check if + slime.elc is older than slime.el and try to help the user out if + so. + +2004-04-06 Marco Baringer mb@bese.it + + * slime.el (slime-repl-command-input-complete-p): New function. + (slime-repl-send-string): New optional arg specifying what string + to put on slime-repl-input-history, usefull when this string + differs from what we actually want to eval. + (slime-repl-return): Check for repl commands and pass then to + slime-repl-send-repl-command. + (slime-repl-send-repl-command): New function. + (slime-kill-all-buffers): New function. + + * swank.lisp: Define the various repl command handlers: sayoonara, + cd, pwd, pack and cload. + + * swank-backend.lisp (quit-lisp): Define as part of the backend + interface and export. + + * swank-sbcl.lisp, swank-openmcl.lisp, swank-cmucl.lisp, + swank-clisp.lisp, swank-allegro.lisp (quit-lisp): implement. + +2004-04-06 Luke Gorrie luke@bluetail.com + + * swank.lisp (macro-indentation): Check that the arglist is + well-formed. This works around a problem with ACL returning + arglists that aren't real lambda-lists. + +2004-04-05 Lawrence Mitchell wence@gmx.li + + * swank.lisp (*swank-pprint-circle*, *swank-pprint-escape*) + (*swank-pprint-level*, *swank-pprint-length*): Fix typo in + docstring. + + * slime.el (slime-arglist): Don't `message' arglist directly, in + case it contains %-signs. + (slime-repl-output-face): Fix quoting. + (slime-symbol-at-point): Call `slime-symbol-name-at-point', + rather than ourselves. + (slime-check-protocol-version): Docstring fix. + +2004-04-05 Luke Gorrie luke@bluetail.com + + * doc/slime.texi (Semantic indentation): Documented new + automatically-learn-how-to-indent-macros feature. + Added auto version control header in subtitle. + + * slime.el (slime-close-parens-at-point): New command bound to + C-a C-a. Inserts close-parenthesis characters at point until the + top-level form becomes well formed. Could perhaps be made fancier. + (slime-update-indentation): New command to update indentation + information (`common-lisp-indent-function' properties) based on + macro information extracted from Lisp. This happens + automatically, the command is just to force a full rescan. + + * swank.lisp (connection): Added slots to track indentation caching. + (*connections*): List of all open connections. + (default-connection): Function to get a "default" + connection. This is intended to support globally using the + debugger hook outside the context of a SLIME request, which is + broken at present. + (with-connection): Don't setup a restart: that must be done + separately. + (sync-state-to-emacs): Call `update-connection-indentation'. + (update-connection-indentation): Automatically discover how to + indent macros and tell Emacs. + + * swank-backend.lisp (arglist): Specify that strings returned + from ARGLIST should be READable. + +2004-04-02 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-maybe-list-compiler-notes): Display the notes + for C-c C-c, when there are notes without a good source-location. + +2004-04-01 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-sbcl.lisp: Remove the non-working workarounds for + non-existent fcntl. Reported by Brian Mastenbrook. + (preferred-communication-style): Use multithreading if futexes are + available, sigio if fcntl is present, and fd-handlers otherwise. + (resolve-note-location): Don't try to construct a source-location + if there's no context. Notes without location will be displayed + in the note-listing buffer. + +2004-04-01 Bill Clementson Bill_Clementson@peoplesoft.com + + * swank-allegro.lisp (send): Fix misplaced parens. + +2004-03-31 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp (debug-function-arglist): Return symbols if + possible. + (class-location): Support for experimental source-location + recording. + +2004-03-30 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-repl-result-face): New face. + (slime-inspector-mode-map): Add a binding for M-. + (compile-defun): Add test case for escaped double quotes inside a + string. + + * swank.lisp (ed-in-emacs): New allowed form for argument. + (pprint-eval-string-in-frame): Apply arguments in proper order. + + * swank-cmucl.lisp (method-dspec): Include method-qualifiers. + (class-definitions): Renamed from struct-definitions. Try to + locate condition-classes and PCL classes (in the future). + (debug-function-arglist): Insert &optional, &key, &rest in the + right places. + (form-number-stream-position): Make it a separate function. + +2004-03-29 Lawrence Mitchell wence@gmx.li + + * swank.lisp (ed-in-emacs): New allowed form for argument. + + * slime.el (slime-ed): Deal with list form of argument. For a + list (FILENAME LINE [COLUMN]), visit the correct line and column + number. + +2004-03-29 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-source-path-parser.lisp (cmucl-style-get-macro-character): + New function. Workaround for bug(?) in SBCL. + (make-source-recording-readtable): Use it. + +2004-03-29 Luke Gorrie luke@bluetail.com + + * HACKING: Some small updates (more needed). + + * slime.el (slime-inspector-buffer): Enter `slime-inspector-mode' + after `slime-mode'. This seems to give priority of keymap to the + inspector, so that it can override SPC. + (slime-easy-menu): Add slime-switch-to-output-buffer. + Enable SLIME menu in the REPL buffer. + (slime-symbol-name-at-point): Avoid mistaking the REPL prompt for + a symbol. + (slime-words-of-encouragement): A few new ones. + (slime-insert-xrefs): Removed the final newline from XREF + buffers. This helps to avoid unwanted scrolling. + + * doc/slime.texi: Added a section about user-interface + conventions and our relationship with inf-lisp. + +2004-03-27 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-changelog-date): Reinitialize it at load-time. + This avoids the need to restart Emacs (horror!) after an update. + + * swank-cmucl.lisp (debug-function-arglist): Properly reconstruct + the arglist from the debug-info. (Not complete yet.) + (arglist): Use it. + + * swank-lispworks.lisp (spawn): Remove CL symbols from + mp:*process-initial-bindings*, to avoid the irritating behavior + for requests executed in different threads. E.g., when someone + tries to set *package*. + + * swank.lisp (*log-io*): New variable. Bind it to *terminal-io* + at load-time, so we can log to a non-redirected stream. + (disassemble-symbol): Allow generalized function names. + (apropos-symbols): Handle the PACKAGE argument properly to get + useful output for C-c P. + + * slime.el (slime-repl-indent-and-complete-symbol): New command. + Bound to TAB in the REPL mode. First try to indent the current + line then try to complete the symbol at point. + (slime-dispatch-event): Ignore a unused thread variable to keep + XEmacs' byte compiler quiet. + + * swank-sbcl.lisp (enable-sigio-on-fd): Use sb-posix::fcntl + instead of sb-posix:fcntl to avoid the ugly reader hack. SBCL + doesn't have package locks and even if they add locks in the + future sb-posix::fcntl will still be valid. + (getpid): Use defimplementation instead of defmethod. + (function-definitions): Take generalized function names ala '(setf + car)' as argument. + +2004-03-26 Luke Gorrie luke@bluetail.com + + * slime.el (slime-group-similar): Bugfix: return NIL if the input + list is NIL. + (slime-inspector-buffer): Enter `slime-inspector-mode' after + `slime-mode'. This seems to give priority of keymap to the + inspector, so that it can override SPC. + +2004-03-26 Bj�rn Nordb� bn@telenor.net + + * swank.lisp (print-arglist): Updated to handle arglists with + string elements, causing arglists for macros to display properly + in LW 4.1. + +2004-03-26 Marco Baringer mb@bese.it + + * swank-cmucl.lisp (set-default-directory): Define only once; + define with defimplementation, not defun. + +2004-03-26 Luke Gorrie luke@bluetail.com + + * slime.el (slime-merge-notes-for-display): New function to merge + together compiler notes that refer to the same location. This is + an optimization for when there are a lot of compiler notes: + `slime-merge-note-into-overlay' concat'd messages together one by + one in O(n^2) time/space, and became noticeably slow in practice + with ~100 notes or more. + (slime-tree-insert): This function is now automatically + byte-compiled (good speed gain). + Wrap byte-compilation in `save-window-excursion' to avoid showing + an unwanted warnings buffer (in XEmacs). + +2004-03-25 Bj�rn Nordb� bn@telenor.net + + * swank-lispworks.lisp: (create-socket, set-sigint-handler) + (who-references, who-binds, who-sets): Add backward compatibility + for LW 4.1. + (dspec-buffer-position): Fix inappropriate use of etypecase. + +2004-03-24 Luke Gorrie luke@bluetail.com + + * swank-sbcl.lisp (getpid): Use sb-posix:getpid. + + * slime.el (slime-inspector-mode-map): Added SPC as extra binding + for slime-inspector-next (like info-mode). + + * doc/slime.texi: Added completion style and configuration. + +2004-03-23 Alan Shutko ats@acm.org + + * swank-clisp.lisp (set-default-directory): New function. + +2004-03-23 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-allegro.lisp (send): Wait a bit if there are already many + message in the mailbox. + + * swank-clisp.lisp (xref-results): Use fspec-location instead of + the of fspec-source-locations. Reported by Alan Shutko. + (break): Be friendly to case-inverting readtables. + + * swank-lispworks.lisp (emacs-connected): Add default method to + environment-display-notifier. Reported by Bj�rn Nordb�. + (set-default-directory, who-specializes): Implemented for + Lispworks. + (gfp): New function. + (describe-symbol-for-emacs, describe-definition): Distinguish + between ordinary and generic functions. + (call-with-debugging-environment): Unwind a few frames. Looks + better and avoids the problems with the real topframe. + (interesting-frame-p): Use Lispworks dbg:*print-xxx* variables to + decide which frames are interesting. + (frame-actual-args): New function. + (print-frame): Use it. + + * swank.lisp (open-streams, make-output-function): Capture the + connection not only the socket. This way the streams can be used + from unrelated threads. Reported by Alain Picard. + (create-connection): Factorized. Initialize the streams after the + connection is created. + (initialize-streams-for-connection, spawn-threads-for-connection): + New functions. + (with-connection): Fix quoting bug and move upwards before first + use. + (guess-package-from-string): Add kludge for SBCL !-package names. + (apropos-list-for-emacs): Lispworks apparently returns duplicates; + remove them. + (inspect-object): Princ the label to allow strings and symbols. + (send-output-to-emacs): Deleted. + (defslimefun-unimplemented): Deleted. Was unused. + + * slime.el (slime-easy-menu): Add some more commands. + (slime-changelog-date): New variable. Initialized with the value + returned by the function of the same name. This detects + incompatible versions if Emacs has not been restarted after an + upgrade. + (slime-check-protocol-version, slime-init-output-buffer): Use it. + (slime-events-buffer, slime-log-event): Use fundamental mode + instead of lisp-mode to avoid excessive font-locking for messages + with lots of strings. + +2004-03-22 Luke Gorrie luke@bluetail.com + + * doc/slime.texi: New user manual. + + * swank.lisp (*communication-style*): New name for + *swank-in-background*. + Exported configuration variables: *communication-style*, + *log-events*, *use-dedicated-output-stream*. + +2004-03-20 Julian Stecklina der_julian@web.de + + * swank-sbcl.lisp (+o_async+, +f_setown+, +f_setfl+): Add correct + constants for FreeBSD. + +2004-03-19 Alan Shutko ats@acm.org + + * swank.lisp, swank-loader.lisp: Take into account + `pathname-device' when deriving paths. A fix for Windows. + +2004-03-19 Luke Gorrie luke@bluetail.com + + * slime.el (slime-connected-hook): New hook called each time SLIME + successfully connects to Lisp. This is handy for calling + `slime-ensure-typeout-frame', if you want to use that feature. + (sldb-print-condition): New command to print the SLDB condition + description into the REPL, for reference after SLDB exits. Can be + called from `sldb-hook' if you want the condition to always be + printed. Bound to 'P' in SLDB. + +2004-03-18 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp (format-values-for-echo-area): Bind *package* to + *buffer-package*. + (load-system-for-emacs): Renamed from swank-load-system. + (carefully-find-package): Be friendly to case inverting + readtables. + (inspect-current-condition): New function. + + * swank-backend.lisp, swank-cmucl.lisp (set-default-directory): + New backend function. + + * swank-allegro.lisp, swank-clisp.lisp, swank-lispworks.lisp, + swank-sbcl.lisp (swank-compile-string): Be friendly to + case-inverting readtables. + + * slime.el (sldb-inspect-condition): Use + swank:inspect-current-condition. + (slime-inspector-label-face): Make it bold by default. + (slime-check-protocol-version, slime-process-available-input): + Wait 2 secs after displaying the error message. + (sldb-list-catch-tags, sldb-show-frame-details): Display catch + tags as symbols not as strings. + +2004-03-16 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-dispatch-event, slime-rex): Pass a form instead + of a string with :emacs-rex. + (slime-connection-name): New connection variable. Use it in + various places instead of slime-lisp-implementation-type-name. + + * swank.lisp: Better symbol completion for case-inverting + readtables. (Thanks Thomas F. Burdick for suggestions.) + (output-case-converter): New function. + (find-matching-symbols): Case convert the symbol-name before + comparing. + (compound-prefix-match, prefix-match-p): Use char= instead of + char-equal. + (case-convert-input): Renamed from case-convert. + (eval-for-emacs): Renamed from eval-string. Take a form instead + of a string. + (dispatch-event, read-from-socket-io): Update callers. + (eval-region, interactive-eval): Use fresh-line to reset the column. + +2004-03-13 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-space): Send a list of the operator names + surrounding point to Lisp. Lisp can use the list to select the + most suitable arglist for the echo area. Suggested by Christophe + Rhodes and Ivan Boldyrev. + (slime-enclosing-operator-names): New function. + + * swank.lisp (arglist-for-echo-area): Renamed from arglist-string. + (format-arglist-for-echo-area, arglist-to-string): New functions. + +2004-03-12 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-backend.lisp (find-definitions): Fix docstring. + + * slime.el (slime-dispatch-event): Re-enable :ed command. + (sldb-return-from-frame): Send swank:sldb-return-from-frame. + + * swank-cmucl.lisp (find-definitions): Allow names like (setf car). + + * swank.lisp (sldb-return-from-frame): Convert the string to a + sexp. + (dispatch-event, send-to-socket-io): Allow %apply events. + (safe-condition-message): Bind *pretty-print* to t. + (set-default-directory): Use the truename. + (find-definitions-for-emacs): Allow names like (setf car). + +2004-03-12 Wolfgang Jenkner wjenkner@inode.at + + * swank.lisp (:swank): Export startup-multiprocessing, + restart-frame, return-from-frame. + What about kill-thread and interrupt-thread, which are accessed + as internal symbols? + +2004-03-10 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp (struct-definitions, find-dd) + (type-definitions, function-info-definitions) + (source-transform-definitions, setf-definitions): New funtions. + (find-definitions): Include struct definitions, deftypes, setf + defintions, compiler-macros and compiler transforms. + +2004-03-10 Andras Simon andras@renyi.hu + + * swank.lisp (print-arglist): Use with-standard-io-syntax. + +2004-03-10 Pawel Ostrowski pasza@zodiac.mimuw.edu.pl + + * swank-cmucl.lisp (unprofile-all): (eval '(profile:unprofile)) + instead of just calling it since it is a macro in cmucl. + + * swank.lisp (:swank): export profile symbols (profiled-functions, + profile-report, profile-reset, unprofile-all, profile-package) + +2004-03-10 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-allegro.lisp, swank-lispworks.lisp, swank-sbcl.lisp, + swank-clisp.lisp, swank-cmucl.lisp (find-definitions): Some + tweaking. + + * swank.lisp (print-arglist): Bind *pretty-circle* to nil to avoid + output like "(function . (cons))". Suggested by Michael Livshin. + (test-print-arglist): Re-enable the tests. + (find-definitions-for-emacs): Renamed from + find-function-locations. + + * slime.el (slime-edit-definition): Renamed from + slime-edit-fdefinition. Display the dspec if there are multiple + definitions. + (slime-symbol-name-at-point): Handle the case when there is no + symbol at point. + (slime-expected-failures): New function + (slime-execute-tests): Use it. + +2004-03-09 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp (frame-source-location-for-emacs): Export it. + Reported by Jouni K Seppanen + (test-print-arglist): Disable the tests until we know what's wrong + with print-arglist. Reported by Michael Livshin. + + * swank-source-path-parser.lisp, swank-gray.lisp (in-package): We + are in-package :swank-backend. Thanks to Raymond Wiker. + + Merge package-split branch into main trunk. + + * swank-clisp.lisp (find-fspec-location): Handle "No such file" + errors. + + * swank-openmcl.lisp (preferred-communication-style): Implemented. + (call-without-interrupts, getpid): Use defimplementation. + (arglist, swank-compile-file, swank-compile-string) + (swank-compile-system, backtrace): Renamed. + (print-frame): New function. + (frame-catch-tags): Don't exclude nil source location. + (format-restarts-for-emacs, debugger-info-for-emacs, + inspect-in-frame). deleted + (frame-arguments): Don't use to-string. + (find-source-locations, find-function-locations + (method-source-location): Deleted. + (canonicalize-location, find-definitions, + function-source-location, list-callers): Use + ccl::edit-definition-p and + ccl::get-source-files-with-types&classes. Makes things easier. + (return-from-frame): Take a sexp not a string. + (describe-definition): Describe more types. + + * swank-loader.lisp: Change load order. swank.lisp is now the last + file. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-gray.lisp, swank-lispworks.lisp, swank-sbcl.lisp, + swank-source-path-parser.lisp: Implement changed backend interface + and remove references to frontend symbols. + + * swank-backend.lisp (:swank-backend): New package. + (definterface): Export the symbol. + (:location, :error, :position, :buffer): Define structure of + source locations here. + (preferred-communication-style, compute-backtrace, print-frame): + New functions. + (debugger-info-for-emacs): Deleted. + + Renaming: + + compile-file-for-emacs -> swank-compile-file + compile-string-for-emacs -> swank-compile-string + compile-system-for-emacs -> swank-compile-stystem + arglist-string -> arglist + backrace -> compute-backtrace + find-function-locations -> find-definitions + + * swank.lisp (:swank): Create the package here. + (*swank-in-background*): Call the backend function + preferred-communication-style to for the initial value. + (find-symbol-designator): Handle NIL properly. + (arglist-string): Renamed from format-arglist. Call backend + function directly. + (*sldb-restarts*, swank-debugger-hook, format-restarts-for-emacs) + (nth-restart, invoke-nth-restart, sldb-abort): Handle restarts in + the front end. + (frame-for-emacs): Renamed from print-with-frame-label. + (backtrace, debugger-info-for-emacs, pprint-eval-string-in-frame) + (set-default-directory): Now in the front end. + (frame-locals-for-emacs): Use print not princ for variable names. + (compile-file-for-emacs, compile-string-for-emacs): Small wrappers + around backend functions. + (describe-definition-for-emacs): Handle unknown symbols before + calling the backend. + (find-function-locations): Wrapper for new backend function + find-definitions. + (group-xrefs, partition, location-valid-p, xref-buffer, xref): + Updated for the new backend functions. + + * slime.el: + (slime-symbol-at-point, slime-symbol-name-at-point): + slime-symbol-at-point calls slime-symbol-name-at-point not the + other way around. This avoids the mess if the symbol at point is + NIL. + (slime-compile-file, slime-load-system, slime-compile-region) + (slime-call-describer, slime-who-calls, sldb-catch-tags): Updates + for renamed lisp functions. + (slime-list-callers, slime-list-callees): Unified with other xref + commands. + (sldb-show-frame-details): Catch tags no longer include the source + location. + (sldb-insert-locals): Simplified. + +2004-03-09 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp (read-into-simple-string): Use the correct fix. + Reported by H�kon Alstadheim. + +2004-03-08 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-start-swank-server, slime-maybe-start-lisp): + Translate filenames. Reported by Dan Muller. + +2004-03-08 Bill Clementson Bill_Clementson@peoplesoft.com + + * slime.el (slime-insert-balanced-comments) + (slime-remove-balanced-comments, slime-pretty-lambdas): New + functions. + +2004-03-07 Jouni K Seppanen jks@iki.fi + + * slime.el (sldb-help-summary): New function. + (sldb-mode): Add docstring so that describe-mode is useful. + (sldb-mode-map): Add bindings for sldb-help-summary and + describe-mode. + (define-sldb-invoke-restart-key): Generate docstrings. + (sldb-default-action/mouse, sldb-default-action) + (sldb-eval-in-frame, sldb-pprint-eval-in-frame) + (sldb-inspect-in-frame, sldb-down, sldb-up, sldb-details-up) + (sldb-details-down, sldb-list-locals, sldb-quit, sldb-continue) + (sldb-abort, sldb-invoke-restart, sldb-break-with-default-debugger) + (sldb-step): Add rudimentary docstrings. + +2004-03-07 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-complete-symbol*, slime-simple-complete-symbol): + Use the correct block name when returning. + (slime-display-completion-list): Fix typo. + + * swank-cmucl.lisp (frame-locals): Use #:not-available instead of + "<not-available>". + +2004-03-05 Bill Clementson Bill_Clementson@peoplesoft.com + + * swank-lispworks.lisp (getpid, emacs-connected): Conditionalize + for Windows. + +2004-03-05 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp (frame-locals-for-emacs): Bind *print-readably* to + nil. + +2004-03-05 Marco Baringer mb@bese.it + + * swank.lisp (frame-locals-for-emacs): New function. + + * slime.el (sldb-frame-locals): Use swank::frame-locals-for-emacs + not swank::frame-locals. + (sldb-insert-locals): use the :value property, not the + :value-string property. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-sbcl.lisp (frame-locals): Return lisp + objects, not strings. Use the :value property and not the + :value-string property. + +2004-03-04 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-display-comletion-list): New function. Set + syntax table properly. + (slime-complete-symbol*, slime-simple-complete-symbol): Use it. + (slime-update-connection-list): New function. + (slime-draw-connection-list): Simplified. + (slime-connection-list-mode-map): Bind g to update-connection-list. + (slime-open-inspector): Print the primitive type in brackets. + (slime-test-arglist): Add test for empty arglist. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-sbcl.lisp, swank-backend.lisp + (thread-alive-p): Add default implementation. + (describe-primitive-type): Add default implementation. + (inspected-parts): Implemented for Allegro and CLISP. + + * swank.lisp (remove-dead-threads): New function. + (lookup-thread): Use it. + (print-arglist): New function. This time without a custom pretty + print dispatch table. + (format-arglist): Use it. + (inspected-parts): Add method for hash-tables. + +2004-03-03 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp: Use *emacs-connection*, *active-threads*, and + *thread-counter* as thread local dynamic variables. + (init-emacs-connection): Don't set *emacs-connection*. + (create-connection, dispatch-event): Pass the connection object to + newly created threads. + (with-connection): New macro + (handle-request, install-fd-handler, debug-thread): Use it. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-openmcl.lisp, swank-sbcl.lisp (call-with-compilation-hooks): + Bind fewer variables. Most of them are already bound in + swank.lisp. + + * swank.lisp (setup-server, serve-connection): New dont-close + argument to keep the socket open after the first connection. + (start-server, create-swank-server): Update callers. + Reported by Bill Clementson. + + * swank-cmucl.lisp (resolve-note-location): Don't be too clever, + if there is no context available. The compiler notes buffer is + probably more adequate in this situation. + (compile-file-for-emacs): Use the :load argument to compile-file. + (inspect-in-frame): Deleted. + + * slime.el (slime-compilation-finished-hook): Use + slime-maybe-list-compiler-notes as default. + (slime-maybe-list-compiler-notes): New function. + (slime-list-compiler-notes): Insert "[no notes]" if there aren't + any. Pop to the buffer. + (slime-complete-symbol*, slime-simple-complete-symbol): Set the + lisp-mode-syntax-table in the completion buffer. + (check-parens): Compatibility function for XEmacs and Emacs 20. + + * swank.lisp (find-completions): Deleted. + (simple-completions): Use longest-common-prefix instead of + longest-completion. + (inspect-in-frame): Moved here from swank-cmucl.lisp. + + * swank-lispworks.lisp (call-with-debugging-environment): Bind + *sldb-top-frame*. + (nth-frame): Use *sldb-top-frame*. + (name-source-location, name-source-locations): Renamed from + dspec-source-location, dspec-source-locations. The result now + includes methods for generic functions. + (eval-in-frame, return-from-frame, restart-frame): Implemented. + (compile-string-for-emacs): Set dspec::*location* to the buffer + location. + (signal-undefined-functions, signal-error-data-base) + (make-dspec-location): Remove temp-file kludges. + (patch-source-locations, replace-source-file): Deleted. + +2004-03-01 Marco Baringer mb@bese.it + + * swank.lisp (format-arglist): deal with nil arglists. + +2004-03-01 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-lispworks.lisp (compile-string-for-emacs): Patch the + recorded source locations. + (replace-source-file, patch-source-locations): New function. + (dspec-buffer-position): Handle defgeneric. + (make-dspec-location): Handle (patched) emacs-buffer locations. + (emacs-buffer-location-p): New function. + (describe-primitive-type, inspected-parts): Implemented. + (kill-thread): Implemented. + + * swank-sbcl.lisp, swank-cmucl.lisp, swank-allegro.lisp + (kill-thread): Implemented. + +2004-02-29 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-complete-symbol): Make slime-complete-symbol + customizable. I don't understand how the ILISP style completion + is supposed to work and find it unintuitive. + (slime-complete-symbol-function): New variable. + (slime-complete-symbol*): Renamed from slime-complete-symbol. + (slime-simple-complete-symbol, slime-simple-completions): New + function. + (slime-compiler-notes-to-tree): Return a list of trees, not a single + tree. + + * swank.lisp (format-arglist): Don't use a custom pprint table. + Didn't work with CLISP and the behavior was different in SBCL and + Lispworks. + (completions): Factorize. + (parse-completion-arguments, format-completion-set, + (completion-set, find-matching-symbols, find-completions): New + functions. + (simple-completions): New function. + (prefix-match-p) New function. + +2004-02-28 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-compilation-finished-hook): New hook variable. + (slime-compilation-finished): Call it. + (slime-maybe-show-xrefs-for-notes): New function. + (slime-make-default-connection): Use the current connection. + (slime-connection-at-point): New function. + (slime-goto-connection, slime-connection-list-make-default): Use + it. + (slime-draw-connection-list): Minor cleanups. + + Define selectors for t and c for thread and connection list. + + * swank.lisp: (*initial-pprint-dispatch-table*) + (*arglist-pprint-dispatch-table*): Workaround for bug in + CLISP. Don't supply nil as argument to copy-pprint-dispatch. + (print-cons-argument): Insert a space after the car. + +2004-02-27 Marco Baringer mb@bese.it + + * slime.el (slime-read-port-and-connect, + slime-read-port-and-connect-to-running-swank): Refactor + slime-read-port-and-connect into two functions so that + slime-thread-attach can use the logic in + slime-read-port-and-connect. + (slime-thread-control-mode-map): Added key bindings for + slime-thread-kill, slime-thread-attach, slime-thread-debug and + slime-list-threads. + (slime-thread-kill, slime-thread-attach, slime-thread-debug): New + functions. + + * swank-backend.lisp (kill-thread): Added to swank interface. + + * swank-openmcl.lisp (kill-thread): Implement. + + * swank.lisp (start-server): Add optional background argument, + defaults to *swank-background*. + (lookup-thread-by-id): New function. + (debug-thread): New function. + +2004-02-26 Peter Seibel peter@javamonkey.com + + * slime.el (slime-draw-connection-list): Use text-properties to + associate the connections each line of the connections list + buffer. + +2004-02-26 Peter Seibel peter@javamonkey.com + + * slime.el (slime-list-connections): Make the buffer created by + this function do a bit more: Can use it to switch to different + connections and change the default. + +2004-02-26 Marco Baringer mb@bese.it + + * swank-openmcl.lisp (ccl::force-break-in-listener): Pass a + condition object to invoke-debugger. + Patch by Bryan O'Connor bryan-slime@lunch.org + +2004-02-26 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-backend.lisp (:swank): export connection-info. + + * swank-allegro.lisp (lisp-implementation-type-name): Implement + it. + + * swank-sbcl.lisp (compile-file-for-emacs): Load the fasl file + regardless of f-p. + + * swank.lisp (swank-pprint): Bind *package* to *buffer-package*. + Reported by Alan Picard. + + * swank-lispworks.lisp (dspec-buffer-position): Renamed from + dspec-buffer-buffer-position. Handle dspecs of the form (defmacro + foo). Reported by Alan Picard. + (arglist-string): Handle unknown arglists properly. + +2004-02-25 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp (arglist-string): Delay the call to + di::function-debug-function until it is actually needed. + (compile-file-for-emacs): Load the fasl file irrespective of + COMILE-FILE's third return value. + + * swank.lisp (connection-info): New function. + (open-streams): Don't send the :check-protocol-version message. Now + handled with CONNECTION-INFO. + + * slime.el (slime-symbol-at-point): Don't skip backwards across + whitespace when we are at the first character of a symbol. To + handle this case: skip symbol constituents forward before skipping + whitespace backwards. Reported by Jan Richter. + (slime-connection-close-hook, slime-next-connection) + (slime-make-default-connection): Remove extra call to format. + (slime-init-connection-state): Use only a single RPC instead of 4. + +2004-02-25 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-with-chosen-connection): Bind + slime-dispatching-connection and not slime-buffer-connection. + slime-buffer-connection is a buffer local variable not a dynamic + variable. + (slime-find-connection-by-type-name) + (slime-read-lisp-implementation-type-name): Were lost during the + merge. + (sldb-fetch-more-frames): Use (goto-char (point-max)) instead of + end-of-buffer. + +2004-02-25 Peter Seibel peter@javamonkey.com + + * slime.el: Various bits of support for maintaining multiple SLIME + connections to different Lisp implementations simultaneously. + + * swank-backend.lisp (lisp-implementation-type-name): Add function to + return simple name of lisp implementation; used by new + multi-connection functionality in slime.el. + +2004-02-25 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp (format-arglist): Use a special pprint-dispatch table. + +2004-02-22 Lawrence Mitchell wence@gmx.li + + * swank.lisp (format-arglist): Bind *PRINT-PRETTY* to NIL. + (eval-in-emacs): Fix typo in docstring. + + * swank-cmucl.lisp (arglist-string): Bind *PRINT-PRETTY* to NIL. + +2004-02-21 Helmut Eller e9626484@stud3.tuwien.ac.at + + Add support for SERVE-EVENT based communication. + + * swank-sbcl.lisp (add-sigio-handler, remove-sigio-handlers): + Renamed. + (add-fd-handler, remove-fd-handlers): Implement interface. + + * swank-cmucl.lisp (fcntl): New function. + (add-sigio-handler, remove-sigio-handlers): Renamed. + (add-fd-handler, remove-fd-handlers): Implement interface. + + * swank.lisp (create-connection): Add support for fd-handlers. + (install-fd-handler, deinstall-fd-handler): New functions. + + * swank-backend.lisp (add-sigio-handler): Renamed from + add-input-handler. + (remove-sigio-handlers): Renamed from remove-input-handlers. + (add-fd-handler, remove-fd-handlers): New interface functions. + + * slime.el (slime-batch-test): Use sit-for instead of + accept-process-output, so that we see something when swank gets + compiled. May be problematic in real batch mode. + (loop-interrupt-continue-interrupt-quit): Wait a second before + interrupting. The signal seems to arrive before the evaluation + request if don't wait => the endless loop is executed inside the + debugger and sldb-quit will not be processed with fd-handlers. + + * swank.lisp (process-available-input): Move auxiliary function to + toplevel. Test if the stream is open. + (install-sigio-handler): Handle the first request after installing + the signal handler. + + * slime.el (slime-keys): Bind C-c C-x t to slime-list-threads and + C-c C-x c to slime-list-connections. + (slime): Disconnect before reconnecting if the inferior-lisp + buffer wasn't renamed. + (slime-connect): Use the host argument and not "localhost". + (slime-compilation-finished): Undo last change. Switch to the + buffer to remove old annotations. + (slime-choose-overlay-region): Ignore errors in + slime-forward-sexp. + +2004-02-18 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime): Just close the connection when called without + prefix-argument. Keeping the connection open doesn't make sense. + We could ask if the Lisp process should be killed, though. + (slime-maybe-close-old-connections): Delete unused function. + (slime-start-swank-server): Use comint-send-string instead of + comint-proc-query, 'cause I don't like Olin "100%" Shivers' code. + (slime-init-output-buffer): Show some animations. + (slime-repl-clear-output): Fixed. + (slime-compilation-finished): It's not necessary to switch to the + original buffer, because the buffer is encoded in the + source-locations. + (sldb-show-source): Don't raise an error if the source cannot be + located. Print a message instead, because errors in + process-filters cause a 1 second delay. + + * swank-cmucl.lisp (read-into-simple-string): Workaround for + read-sequence bug in 18e. + +2004-02-18 Peter Seibel peter@javamonkey.com + + * swank-loader.lisp: Place the fasl files of different + implementations in different directories. + +2004-02-18 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-clisp.lisp: Update comments about metering package. + + * metering.lisp: Imported from CLOCC. Suggested by Peter Seibel. + +2004-02-17 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp, slime.el (make-compiler-note): Don't send the + short-message across the wire if the slot is nil. + + * swank-cmucl.lisp (clear-xref-info): Compare the truenames with + equalp instead of the unix-truenames. The old version was very + inefficient (clearing the tables with about 1000 entries required + serveral seconds). + (xref-context-derived-from-p, pathname=): Delete unused functions. + + * swank-clisp.lisp (remove-input-handlers): + socket:socket-stream-handle is not available on Windows. + Reported by Alan Shutko. + + * slime.el (slime-length>): New function. + (slime-compiler-notes-to-tree): Don't collapse if there is only + one kind of notes. + +2004-02-16 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp (make-compiler-note): Include short-message. + + * swank-sbcl.lisp (signal-compiler-condition): Initialize + short-message slot. + (long-compiler-message-for-emacs): New function. + + * swank-cmucl.lisp (handle-notification-condition): Don't use the + context of the previous message. + (signal-compiler-condition): Set short message slot. + (long-compiler-message-for-emacs): New function. + (sigio-handler): Ignore arguments. + + * swank-clisp.lisp (set-sigio-handler, add-input-handler): + Conditionalize for linux. + + * swank-backend.lisp (compile-system-for-emacs): Add default + implementation. + (compiler-condition): New slot short-message. + + * slime.el (slime-compilation-finished): Display compiler notes + grouped by severity in a separate buffer. + (slime-compilation-finished-continuation, slime-compile-file) + (slime-load-system, slime-compile-string): Update callers. + (slime-list-compiler-notes, slime-alistify, slime-tree-for-note) + (slime-tree-for-severity, slime-compiler-notes-to-tree) + (slime-compiler-notes-mode, slime-compiler-notes-quit): New + functions. + (with-struct, slime-tree): New code for pseudo tree widget. + (slime-init-connection-state): Set slime-state-name to "". + +2004-02-08 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp (create-socket): Fix last fix. Use the proper + port argument. + + * swank-allegro.lisp, swank-backend.lisp, swank-clisp.lisp, + swank-cmucl.lisp, swank-lispworks.lisp, swank-openmcl.lisp, + swank-sbcl.lisp (create-socket): Take interface as argument. + + * slime.el (sldb-show-frame-details): Fix typos. + (slime-print-apropos): Don't bind action. + (slime-reset): Kill sldb-buffers. + (slime-test-find-definition, slime-test-complete-symbol) + (slime-test-arglist): Add more slime-check-top-level calls. + + * swank.lisp (setup-server): Pass loopback-interface to + create-socket. Reported by Dirk Gerrits. + (*loopback-interface*): New parameter. + (sldb-loop): Send :debug event inside unwind-protect, so we never + lose the corresponding :debug-return event. + +2004-02-08 Marco Baringer mb@bese.it + + * swank-openmcl.lisp (find-source-locations): Eliminate unused + variable warning. + + * swank.lisp (swank-pprint): Bind pretty print vars to + *swank-pprint-X* counter parts. + (*swank-pprint-circle*, *swank-pprint-escape*, + *swank-pprint-level*, *swank-pprint-length*): Swank counterparts + to *print-X* variables used when swank needs to pretty print a + form. + (apply-macro-expander): Use swank-pprint. + +2004-02-07 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp (send, receive, interrupt-thread): Implement + more threading functions. + + * swank-sbcl.lisp (inspected-parts): Implemented. + + * slime.el (slime-rex): Mention thread argument in docstring. + (sldb-break-with-default-debugger): Use slime-rex and don't switch + to the output buffer (happens automatically). + (slime-list-threads): Renamed from slime-thread-control-panel. + (slime-thread-insert): Use slightly different layout. + (slime-give-goahead, slime-waiting-threads) + (slime-popup-thread-control-panel, slime-register-waiting-thread) + (slime-thread-goahead): Deleted. + (slime-maybe-start-multiprocessing): Call + swank:startup-multiprocessing. Reported by Paolo Amoroso. + + * swank.lisp (dispatch-event): :debug, :debug-condition, + :debug-activate events were all encoded as :debug events, which + means the debugger never worked! Fix it. I guess no one uses + SLIME with a multithreaded Lisp. + (read-user-input-from-emacs): Flush the output before reading. + (sldb-loop): Add a sldb-enter-default-debugger tag, so we can + enter the default debugger by throwing to it. + (sldb-break-with-default-debugger): Throw to + sldb-enter-default-debugger. + (*thread-list*): New variable. + (list-threads): New function. + + * swank-backend.lisp (thread-name): Take a thread object as + argument. + (thread-status, all-threads, thread-alive-p): New function. + (thread-id): Deleted. + + * swank-allegro.lisp, swank-cmucl.lisp, swank-lispworks.lisp, + swank-openmcl.lisp, swank-sbcl.lisp: Update for modified thread + interface. + + * swank-sbcl.lisp (enable-sigio-on-fd): New function. Use + fallback if sb-posix:fcntl isn't fbound. + + * swank-cmucl.lisp (gf-definition-location): Return an error when + pathname for the GF is nil (this happens if the GF is not compiled + from a file). + + * swank.lisp (undefine-function): New function. + (print-with-frame-label, print-part-to-string): Bind + *print-circle* to t, to avoid unbound recursion when printing + cyclic data structures. + + * slime.el (slime-undefine-function): New command. Bound to C-c + C-u. + +2004-02-06 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (sldb-setup): Offer to enter a recursive edit if there + are pending continuations. + (slime-eval): Unwind the stack, thereby exititing recursive edits, + before signaling the error. + +2004-02-05 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-openmcl.lisp (compile-system-for-emacs): Remove compile + time dependency on ASDF. + +2004-02-05 Wolfgang Jenkner wjenkner@inode.at + + * swank-clisp.lisp, swank-loader.lisp: Add profiling support via + Kantrowitz's metering package. Reporting needs to be + refined (profile-package currently ignores callers-p and methods). + +2004-02-04 Bryan O'Connor bryan-slime@lunch.org + + * swank-openmcl.lisp (mailbox): Use a semaphore instead of + process-wait. Works better with native threads. + +2004-02-04 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-backend.lisp (debugger-info-for-emacs): Export it. + + * swank-sbcl.lisp (add-input-handler): Use fcntl from the sb-posix + package. + + * swank.lisp (sldb-loop, dispatch-event, send-to-socket-io): Send + a :debug-activate event instead of a :debug event (to avoid + sending a potentially long backtrace each time). + (handle-sldb-condition): Include the thread-id in the message. + + * slime.el (slime-path): Use load-file-name as fallback. + Suggested by Lawrence Mitchell. + (slime-dispatch-event): Add support for :debug-activate event. + (sldb-activate): New function. + (sldb-mode): make-local-hook doesn't seem to work in Emacs 20. + Use a buffer local variable instead. + (slime-list-connections): Don't print Lisp's state. + (slime-short-state-name): Deleted. + +2004-02-02 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-debugger): The customization group is called + 'slime-debugger', fix referrers. Reported by Jouni K Seppanen. + + * swank.lisp (simple-break): Bind *debugger-hook* before invoking + the debugger. Reported by Michael Livshin. + +2004-01-31 Robert E. Brown bbrown@speakeasy.net + + * swank-sbcl.lisp, swank.lisp: Add more type declarations and + detect missing initargs for the connection struct. + +2004-01-31 Jouni K Seppanen jks@iki.fi + + * slime.el (slime-path): Placed inside an eval-and-compile. Works + around some problems when byte-compiling slime-changelog-date. + +2004-01-31 Marco Baringer mb@bese.it + + * swank-openmcl.lisp: remove defslimefun-unimplemented forms. + (call-with-compilation-hooks, compile-system-for-emacs): Implement + them. + (compile-file-for-emacs, compile-string-for-emacs): Use + with-compilation-hooks. + (list-callers): Define with defimplementation and not defslimefun. + + * swank-backend.lisp (compile-system-for-emacs): Declare method + as part of the interface. + + * slime.el (slime-find-asd): Handle files whose directory does + not contain an asdf system definition. + +2004-01-31 Helmut Eller e9626484@stud3.tuwien.ac.at + + Merge stateless-emacs branch into main trunk. We use now signal + driven IO for CMUCL and one thread per request for multithreaded + Lisps. + +2004-01-31 Robert E. Brown bbrown@speakeasy.net + + * swank-backend.lisp, swank-sbcl.lisp, + swank-source-path-parser.lisp, swank.lisp: Add type declarations + to keep SBCL quiet. + +2004-01-29 Michael Weber michaelw+slime@foldr.org + + * slime.el, swank-backend.lisp, swank-cmucl.lisp, swank-sbcl.lisp, + swank.lisp: Profiler support. + +2004-01-23 Alan Ruttenberg alanr-l@mumble.net + + * swank-openmcl.lisp: Bind ccl::*signal-printing-errors* to nil + inside debugger so that error while printing error take us down. + +2004-01-23 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-sbcl.lisp (eval-in-frame, return-from-frame): Implemented. + (sb-debug-catch-tag-p): New auxiliary predicate. + (source-path<): Delete unused function. + +2004-01-23 Michael Weber michaelw@foldr.org + + * slime.el (slime-keys): Bind C-c M-p to slime-repl-set-package. + (slime-easy-menu): Add entry for slime-repl-set-package. + +2004-01-23 Michael Weber michaelw@foldr.org + + * slime.el (slime-repl-set-package): New command to set the + package in the REPL buffer. + + * swank.lisp (set-package): Return the shortest nickname. + +2004-01-23 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (sldb-disassemble): Was lost somewhere. + +2004-01-22 Wolfgang Jenkner wjenkner@inode.at + + * swank-clisp.lisp: Replace defmethod by defimplementation where + appropriate. + (return-from-frame, restart-frame): Implement them. + +2004-01-22 Helmut Eller e9626484@stud3.tuwien.ac.at + + * test.sh: Copy the ChangeLog file too. + + * swank-cmucl.lisp: Replace some defmethods with + defimplementation. + + * swank-allegro.lisp (return-from-frame, restart-name): Implement + interface (partly). + + * swank-openmcl.lisp (restart-frame, return-from-frame): Remove + sldb-prefix. + + * swank-backend.lisp (return-from-frame, restart-frame): + Are now interface functions. + + * swank.asd: Remove dependency on :sb-bsd-sockets. Is already + done in swank-sbcl. + + * swank-loader.lisp: Don't reference the swank package at + read-time. + + * swank.lisp (completions): Never bind *package* to nil. That's a + type error in SBCL. + (swank-debugger-hook): Flush the output streams and be careful + when accessing *buffer-package*. + (create-swank-server): Return the port of the serve socket. + + * swank-lispworks.lisp (interesting-frame-p): Don't print catch + frames. + (make-sigint-handler): New function. + (emacs-connected): Use it. + + * slime.el (slime-lisp-implementation-type): New per connection + variable. + (slime-handle-oob): Handle debug-condition event. Can be signaled + CMUCL when cannot produce a backtrace. + (slime-debugging-state): Don't pop up the debugger buffer an + activate events. Annoying. + (sldb-break-with-default-debugger): Switch to the output buffer + before returning to the tty-debugger. + (sldb-return-from-frame, sldb-restart-frame): Use slime-rex. + (slime-list-connections, slime-short-state-name): New functions. + +2004-01-20 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-complete-symbol): Insert the completed-prefix + before deleting the original text to avoid troubles with left + inserting markers. + (slime-symbol-start-pos): Skip backward across symbol + constituents. + (slime-evaluating-state): [:read-sring] Save the window + configuration. + (slime-read-string-state): Don't handle activate events + (troublesome if, e.g, complete-symbol is used from another + buffer). Restore the window configuration. + (slime-repl-read-string): Goto the end of buffer. + (slime-debugging-state): [:activate] Display the debugger buffer + if not visible. + (slime-to-lisp-filename, slime-from-lisp-filename) + (slime-translate-to-lisp-filename-function) + (slime-translate-from-lisp-filename-function, slime-compile-file) + (slime-goto-location-buffer, slime-ed, slime-load-file): Support + for remote filename translation (untested). + + * swank.lisp (create-swank-server): Take announce-fn as optional + argument. + + * swank-allegro.lisp: Replace defmethod with defimplementation. + (eval-in-frame): Implemented. + +2004-01-20 Lasse Rasinen lrasinen@iki.fi + + * slime.el (slime-prin1-to-string): Replacement for + prin1-to-string that avoids escaping non-ascii characters in a + way that the CL reader doesn't understand. Allows use of 8-bit + characters in Lisp expressions with Emacs in unibyte-mode. + +2004-01-20 Luke Gorrie luke@bluetail.com + + * slime.el (slime-eval-print-last-expression): Insert a newline + before and after the result. + (slime-easy-menu): Added menu items: + "Eval Region", "Scratch Buffer", "Apropos Package..." + Added some bold to default SLDB faces. + +2004-01-19 Alan Ruttenberg alanr-l@mumble.net + *swank-openmcl.lisp in frame-catch-tags, ppc32::catch-frame.catch-tag-cell -> 0, + ppc32::catch-frame.csp-cell -> 3. FIXME when this code is more stable in openMCL. + +2004-01-19 Michael Weber michaelw@foldr.org + + * slime.el (slime-close-all-sexp): New command to close all + unmatched parens in the current defun. Bound to `C-c C-]'. With + prefix argument, only operate in the region (for closing + subforms). + +2004-01-19 Luke Gorrie luke@bluetail.com + + * swank-openmcl.lisp (thread-id, thread-name): Fixed silly bugs + (thanks Marco Baringer). + + * swank-loader.lisp: Call (swank:warn-unimplemented-interfaces). + + * swank.lisp (ed-in-emacs): New command with the same interface + as CL:ED. + + * swank-cmucl.lisp, swank-sbcl.lisp, swank-lispworks.lisp, + swank-openmcl.lisp, swank-allegro.lisp, swank-clisp.lisp: Updated + to use `defimplementation'. + + * swank-backend.lisp (definterface, defimplementation): New macros + as sugar around defgeneric/defmethod. This supports conveniently + supplying a default (on NO-APPLICABLE-METHOD). Because the + underly mechanism is still generic functions this doesn't break + code that isn't updated. + (warn-unimplemented-interfaces): Print a list of backend functions + that are not implemented. + (xref and list-callers): Defined interfaces for these functions. + (describe-definition): New function that takes over from the many + other describe-* functions called from apropos listing. Takes the + type of definition (as returned by describe-symbol-for-emacs) as + an argument. + + * slime.el (sldb-enable-styled-backtrace): This is now true by + default. + (slime-keys): Bound `slime-inspect' to `C-c I'. + (slime): `M-x slime' now offers to keep existing connections + alive (else disconnect them). If you disconnect them, the new + connection gets to reuse the existing REPL. + (slime-connection): Error if the connection is closed. + (slime-handle-oob): New message (:ED WHAT) for `slime-ed'. + (slime-display-output-buffer): Don't pop up the REPL if it is + already visible in any frame. + (slime-find-asd): Handle case where (buffer-file-name) is nil. + (slime-ed): Elisp backend for (CL:ED WHAT). + (slime-apropos): Add a summary line to apropos listings. + (slime-print-apropos): Replaced `action' property (name of lisp + describe function) with `type' (argument to pass to unified + swank:describe-definition function). + (slime-apropos-package): New command on `C-c P'. Presents apropos + listing for all external (with prefix also internal) symbols in a + package. + +2004-01-18 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-lispworks.lisp (sigint-handler): Bind a continue restart. + (make-dspec-location): Handle strings like pathnames. + Some multithreading support. + + * slime.el (compile-defun): Don't use keywords. The keyword + package is locked in Lispworks and causes the test-suite to hang. + (slime-eval-with-transcript): Fix bug triggered when 'package' is + a buffer local variable. Reported by Janis Dzerins. + (slime-batch-test): Wait until the connection is ready. + +2004-01-18 Alan Ruttenberg alanr-l@mumble.net + + * swank-openmcl: Implement frame-catch-tags. Added debugger functions + sldb-restart-frame, sldb-return-from-frame. Should probably be added to backend.lisp + but let's discuss first. Do other lisps support this? + + * slime.el sldb-restart-frame, sldb-return-from-frame + +2004-01-18 Wolfgang Jenkner wjenkner@inode.at + + * swank-clisp.lisp (call-without-interrupts): Evaluate + linux:SIGFOO at read time since the macro with-blocked-signals + expects a fixnum. + (compile-file-for-emacs): Comment fix. + +2004-01-18 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-sbcl.lisp (make-fn-streams): Deleted. Already defined in + swank-gray.lisp. + + * swank.lisp (find-symbol-or-lose, format-arglist): New functions. + (without-interrupts): New macro. + (send-to-emacs): Use it. + + * swank-backend.lisp, swank-clisp.lisp, swank-lispworks.lisp, + swank-openmcl.lisp, swank-sbcl.lisp, swank-allegro.lisp: + (arglist-string): Refactor common code to swank.lisp. + (call-without-interrupts, getpid): Are now generic functions. + + * slime.el (arglist): Test slot readers and closures. + + * swank-cmucl.lisp (arglist-string): Use + pcl:generic-function-lambda-list for generic functions. Handle + closures. Print arglist in lower case. + (inspected-parts-of-value-cell): Was lost during the inspector + refactoring. + +2004-01-18 Wolfgang Jenkner wjenkner@inode.at + + * swank-clisp.lisp (compile-file-for-emacs, + split-compiler-note-line): Revert last change. + (handle-notification-condition): Don't signal the condition. + (*compiler-note-line-regexp*): Fix and rewrite it as extended + regexp. + + * slime.el (slime-changelog-date): Use file-truename of + byte-compile-current-file. + +2004-01-17 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-format-arglist): Add some sanity checks and + print zero argument functions nicer. Suggested by Ivan Boldyrev. + (slime-test-expect): Take test predicate as argument. + (arglist): Test generic functions. + + * swank-cmucl.lisp (arglist-string): Handle generic functions + better. Reported by Ivan Boldyrev. + +2004-01-16 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-allegro.lisp: Multiprocessing support. + + * swank-openmcl.lisp, swank-cmucl.lisp, swank-backend.lisp, + swank.lisp: Refactor inspector code. + + * swank.lisp (changelog-date): Use *compile-file-truename* instead + of *compile-file-pathname*. + (with-I/O-lock, with-a-connection): The usual CLISP fixes. + (create-swank-server): Patch by Marco Baringer mb@bese.it. + Bring it back again. + (create-connection): Use return the dedicated output stream if + available. + + * slime.el: Numerous REPL related fixes. + (slime-update-state-name): Take state as argument. + (slime-repl-beginning-of-defun, slime-repl-end-of-defun): Fix + typos. + (sldb-insert-restarts): Remove duplicate definition. + +2004-01-16 Luke Gorrie luke@bluetail.com + + * swank-openmcl.lisp: Multiprocessing support. + + * swank.lisp (changelog-date): make-pathname portability fix + (from alanr). + (with-io-redirection): Use (current-connection) instead of + *dispatching-connection* (from alanr). + + * slime.el (slime-init-output-buffer): XEmacs portability fix, and + use header-line-format to show info about Lisp in Emacs21. + +2004-01-15 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-sbcl.lisp, swank-cmucl.lisp (remove-input-handlers): New + method. + + * swank-allegro.lisp (excl:stream-read-char-no-hang): Import it. + (emacs-connected): Add default method. The method for + no-applicable-method doesn't seem to work. ACL bug? + + * swank-loader.lisp (compile-files-if-needed-serially): Don't + handle compilation errors. We must compile everything because + changelog-date requires *compile-file-truename*. + + * slime.el: (slime-changelog-date) + (slime-check-protocol-version): New functions. + (slime-handle-oob): Handle :check-protocol-version event. + (slime-init-output-buffer): Print some info about the remote Lisp. + (slime-connect): Use it. + (slime-note-transcript-start): Renamed from + slime-insert-transcript-delimiter. + (slime-note-transcript-end): New function. + (slime-with-output-end-mark, slime-repl-insert-prompt) + (slime-repl-show-result, slime-compile-file) + (slime-show-evaluation-result): Insert output from eval commands + after the prompt and asynchronous output before the prompt. Needs + documentation. + (repl-test, repl-read, interactive-eval-output): New tests. + (slime-flush-output): Accept output from all processes. + + * swank.lisp (serve-requests): New function. + (setup-server): Use it. + (start-server): Pass backgroud to setup-server. + (create-connection): Check the protocol version. + (changelog-date): New function. + (make-output-function): Use write-string instead of princ. + + * swank-backend.lisp (remove-input-handlers): New function. + +2004-01-15 Luke Gorrie luke@bluetail.com + + * slime.el (slime-aux-connect, slime-handle-oob): Support for + (:open-aux-connection port) message where Lisp requests that + Emacs make a connection. These are "auxiliary" connections which + don't (or at least shouldn't) have their own REPL etc. + + * swank.lisp: New support for multiprocessing and multiple + connections + commentary. + (with-a-connection): Macro to execute some forms "with a + connection". This is used in the debugger hook to automatically + create a temporary connection if needed (i.e. if the current + thread doesn't already have one). + (open-aux-connection): Helper function to create an extra + connection to Emacs. + + * swank-sbcl.lisp: Implemented multiprocessing. Not perfect. + + * swank-cmucl.lisp: Implemented new multiprocessing interface. + (create-socket): Make FDs non-blocking when multiprocessing is + enabled. + (startup-multiprocessing): Set *swank-in-background* to :spawn. + + * swank-backend.lisp: Changed multiprocessing interface. + +2004-01-15 Wolfgang Jenkner wjenkner@inode.at + + * swank-clisp.lisp (with-blocked-signals): New macro. + (without-interrupts): Use it. + (*use-dedicated-output-stream*, *redirect-output*): Don't set them + here, use the default settings. + Make :linux one of *features* if we find the "LINUX" package. + +2004-01-14 Luke Gorrie luke@bluetail.com + + * swank-openmcl.lisp (emacs-connected): Typo fix (missing + close-paren). + +2004-01-13 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-input-complete-p): Tolerate extra close parens. + (slime-idle-state): Don't active the repl. + (slime-insert-transcript-delimiter): Insert output before prompt. + (slime-open-stream-to-lisp): Initialize the process-buffer with + the connection buffer. + (slime-repl-activate): Deleted. + (slime-repl-eval-string, slime-repl-show-result) + (slime-repl-show-abort): Better handling of abortion. + (slime-compile-file): Insert output before prompt. + + * swank-lispworks.lisp (create-socket): Fix condition message. + + * swank-openmcl.lisp (*swank-in-background*): Set to :spawn. + (emacs-connected): Initialize ccl::*interactive-abort-process*. + + * swank.lisp (*swank-in-background*): New variable. + (start-server): Start swank in background, depending on + *swank-in-background*. + + * swank-cmucl.lisp, swank-sbcl.lisp (*swank-in-background*): Set + to :fd-handler. + + * swank-clisp.lisp (accept-connection): Remove superfluous call to + socket-wait. + + New more direct socket interface. The new interface is closer to + the functions provided by the implementations. For Lispworks we + use some non-exported functions to get a sane interface. The + interface also includes add-input-handler and a spawn function + (not used yet). The idea is that most of the logic can be shared + between similar backends. + + * swank-gray.lisp (make-fn-streams): New function. + (stream-read-char-no-hang, stream-read-char-will-hang-p): Moved to + here from swank-clisp.lisp. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp: + (create-socket, local-port, close-socket, accept-connection) + (add-input-handler, spawn): Implement new socket interface. + + * swank.lisp (start-server, open-dedicated-output-stream &etc): + Use new socket functions. + + * swank-backend.lisp (create-socket, local-port, close-socket) + (accept-connection, add-input-handler, spawn): New functions. + (accept-socket/stream, accept-socket/run): Deleted. + +2004-01-13 Luke Gorrie luke@bluetail.com + + * swank-clisp.lisp: Updated for new network interface but not + tested! Probably slightly broken. + + * swank-lispworks.lisp: Updated for new network interface. + (accept-socket/stream): This function is currently broken, so + LispWorks can't use the dedicated output channel at the moment. + + * swank.lisp, swank-cmucl.lisp, swank-sbcl.lisp: Updated for new + network interface. + + * swank-backend.lisp (accept-socket/stream, accept-socket/run): + New functions replacing the ancient (over 24 hours!) + `create-socket-server'. This interface is much simpler. + +2004-01-12 Luke Gorrie luke@bluetail.com + + * swank-lispworks.lisp: Partially updated for new backend + interface, but not actually working. The sockets code is broken, I + haven't grokked LispWorks the interface properly. + + * swank-gray.lisp (slime-input-stream, slime-output-buffer): Added + slots to support the new `make-fn-streams' interface from + swank-backend.lisp. These slots need to be initialized by the + backend, see swank-sbcl.lisp for an example (very easy). + + * swank-sbcl.lisp (create-socket-server): Implemented new server + interface. + + * slime.el (slime-handle-oob): Added + :open-dedicated-output-stream message, previously implemented + with :%apply. + (slime-repl-read-string, slime-repl-return-string): Pass integer + argument to `slime-repl-read-mode' to set rather than toggle. + + * swank.lisp: Taking over previously non-portable jobs: + (start-server): Now only uses sockets code from the backend. + (handle-request): Top-level request loop. + (open-dedicated-output-stream): Dedicated output socket. + (connection): New data structure that bundles together the things + that constitute a connection to Emacs: socket-level stream and + user-level redirected streams. + + * swank-cmucl.lisp (create-socket-server): Generic TCP server + driven by SERVE-EVENT. + (serve-one-request, open-stream-to-emacs): Deleted. Now handled + portably in swank.lisp. + (make-fn-streams): Implement new stream-redirection interface. + (slime-input-stream): New slot referencing output sibling, so it + can be forced before input requests. + + * swank-backend.lisp (create-socket-server): Generic + callback-driven TCP server interface. Replaces + `create-swank-server', with the higher-level logic moved into + swank.lisp. + (emacs-connected): Invoked when Emacs initially connects, as a + hook for backend implementations. + (make-fn-streams): Interface for creating pairs of input/output + streams that are backended by callback functions. Used to + implement redirected-via-Emacs standard I/O streams. + +2004-01-12 Lawrence Mitchell wence@gmx.li + + * slime.el (slime-events-buffer): Set `hs-block-start-regexp' + before running `hs-minor-mode'. + +2004-01-10 Luke Gorrie luke@bluetail.com + + * slime.el (package-updating): Expected package is now a list (can + be any), since the shortest nickname is not + standardized. e.g. USER or CL-USER for COMMON-LISP-USER. + + * swank-cmucl.lisp: Don't enable xref (let the user decide). + (set-fd-non-blocking): Removed unused function. + Miscellaneous refactoring of the networking code. + + * slime.el (slime-complete-symbol): Use markers to hold the + beginning and end of the completion prefix, in case looking up + completions causes insertions (e.g. GC announcements). + +2004-01-09 Luke Gorrie luke@bluetail.com + + * slime.el (slime-activate-state): Only update state name when + `slime-default-connection' activates. This fixes an annoying + "Selecting deleted buffer" bug that prevented SLIME from being + restarted. + (slime-next-connection): Fixed a bug where buffer-local connection + bindings could get in the way and prevent the connection from + actually changing. + (slime-complete-restore-window-configuration): Wrap + `set-window-configuration' in `save-excursion'. This fixes a + problem where the cursor would end up in the wrong place after + completion in XEmacs. + +2004-01-09 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: Place (require 'cl) inside a eval-and-compile. + (slime-with-connection-buffer): Move definition upwards before the + first use. + (package-updateing): New test for package updates in the listeners. + + * swank.lisp (eval-region): Bind *package* outside the + unwind-protect to detect updates. + + * swank-backend.lisp (debugger-info-for-emacs) + (find-function-locations): Doc fix. + +2004-01-09 Wolfgang Jenkner wjenkner@inode.at + + * swank-clisp.lisp: Add methods for GRAY:STREAM-READ-CHAR-NO-HANG + and for the CLISP specific GRAY:STREAM-READ-CHAR-WILL-HANG-P. + This should fix the behaviour of SYS::READ-FORM. + +2004-01-08 Luke Gorrie luke@bluetail.com + + * slime.el (slime-inspector-fontify): Function to insert a string + in a particular inspector face. Replaces macro-code-generation + function `slime-inspector-expand-fontify'. Fixes a byte-compile + problem (macro was calling function not defined at compile-time). + +2004-01-07 Luke Gorrie luke@bluetail.com + + * slime.el: Multisession internal improvements. Now there are + three separate connection variables, in order of priority: + slime-dispatching-connection (dynamically-bound) + slime-buffer-connection (buffer-local) + slime-default-connection (global) + The most specific one available is used. This is splitting + `slime-connection' into multiple variables, so that you can be + specific about what you want to assign (i.e. know if you're + setting a dynamic binding or a buffer-local one). + Fixed some related bugs. + (slime-connection-close-hook): If default connection closes, + select another connection. + (slime-lisp-package): Initially CL-USER nickname instead of + COMMON-LISP-USER (for REPL prompt). + + * slime.el (slime): Multisession support: with prefix argument, + gives the option of keeping existing sessions and firing up an + additional *inferior-lisp* to connect to. Each connection now has + its own *slime-repl[<n>]* buffer. + (slime-connection): Should now be read via the function of the + same name. The accessor will check if the value is NIL, and if so + use `slime-default-connection'. + (slime-default-connection): The connection that will be used by + default, i.e. unless `slime-connection' is bound. Renamed from + `slime-primary-connection'. + (slime-init-connection-state): When reconnecting, update the + `slime-connection' binding in the REPL to use the new connection. + (slime-repl-input-history, ...): REPL variables are now + buffer-local. + +2004-01-06 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp (eval-string): New argument 'id'. Used to identify + the remote continuation. + (log-event): New debugging function. + (read-from-emacs, send-to-emacs): Use it. + + * slime.el: The new macro 'slime-rex' can now be used to evaluate + sexps remotely. It offers finer control what to do when the + evaluation aborts. + (slime-rex): New macro + (slime-eval, slime-eval-async, sldb-continue) + (sldb-invoke-restart): Use it. + (slime-continuation-counter, slime-push-evaluating-state): New + functions. + (slime-output-buffer): Initialize markers. + (sldb-mode): XEmacs doesn't like (add-hook (make-local-hook ...)). + (slime-init-connection): New optional argument SELECT. + (slime-def-connection-var): Workarounds for Emacs 20 reader bugs. + Backquote is pretty broken Emacs 20. + +2004-01-06 Ignas Mikalajunas i.mikalajunas@mbt.lt + + * swank-loader.lisp (user-init-file): Use merge-pathames. Fix + Windows support. + +2004-01-05 Luke Gorrie luke@bluetail.com + + * slime.el: Multiple session support, i.e. Emacs can open + multiple connections to Lisps. The guts is there, but + user-interface is currently minimal. + (slime-net-process): Replaced with slime-net-processes. + (slime-net-send): Take process as argument. + (slime-process-available-input): Poll all connections. + (slime-connection): Current connection (process) to use for + talking to Lisp. Can be bound dynamically or buffer-local. + (slime-with-connection-buffer): Macro to enter the process-buffer + of `slime-connection' to manipulate the local variables. + (slime-stack-stack): Now buffer-local in the process-buffer of + each connection. + (slime-push-state, slime-pop-state): Operate on the stack inside + `slime-connection's process-buffer. + (slime-dispatch-event): Take optional process argument, to bind + `slime-connection' appropriately when events arrive from the + network. + (slime-def-connection-var): Macro to define variables that are + "connection-local". Such variables are used via (setf'able) + accessor functions, and their real bindings exist as local + variables in the process-buffers of connections. The accessors + automatically work on `slime-connection'. + (slime-lisp-features, slime-lisp-package, slime-pid, sldb-level): + These variables are now connection-local. + (slime-read-from-minibuffer): Inherit `slime-connection' as + buffer-local so that we complete towards the right Lisp. + (sldb-mode): Inherit `slime-connection' as buffer-local so that we + debug towards the right Lisp. + (get-sldb-buffer): New function to return (optionally create) the + SLDB buffer for the current connection. Since multiple Lisps can + be debugged simultaneously, the buffername now includes the + connection number. + (slime-connection-abort): New command to abort a connection + attempt (don't use `slime-disconnect' anymore - that closes all + connections). + (slime-execute-tests): Honor `slime-test-debug-on-error'. + (slime-next-connection): Cycle through open Lisp connections. + +2004-01-02 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-display-output-buffer): Move the output markers + to the end of the buffer. + + * swank-clisp.lisp (frame-do-venv): Rename the :symbol property to + :name. + (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + + * swank-openmcl.lisp (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + (frame-locals): Rename the :symbol property to :name. + + * swank-lispworks.lisp (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + (frame-locals): Rename the :symbol property to :name. + + * swank-allegro.lisp (frame-locals): Rename the :symbol property + to :name. + (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + + * swank-sbcl.lisp (tracedp, toggle-trace-fdefinition) + (format-condition-for-emacs): Remove unused functions. + (format-frame-for-emacs): Use print-with-frame-label. + (compute-backtrace): Simplified. + (backtrace): Return our frame numbers. + (frame-locals): Rename the :symbol property to :name. Remove the + :validity property. + + * swank-cmucl.lisp (accept-loop, safe-definition-finding): Doc + fix. + (location-buffer=, file-xrefs-for-emacs) + (sort-contexts-by-source-path, source-path<) + (format-condition-for-emacs): Remove unused functions. + (format-frame-for-emacs): Don't include the frame number in the + description, but use the frame number for indentation. Update + callers. + (frame-locals): Rename the :symbol property to :name. + + * slime.el (slime-add-face): New function. + (sldb-add-face): Use it. + (sldb-setup): Some refactoring. + (sldb-insert-condition): New function. Factorized from + sldb-setup. Message and types are now separate. + (sldb-insert-restarts): New function. Factorized from sldb-setup. + (sldb-insert-frame): Factorized from slime-insert-frames. The + frame number in no longer part of the string describing the frame. + (sldb-insert-frames): Use it. + (sldb-show-frame-details): Print frame numbers. Fix printing of + catch tags. Move to the start of the frame before at the + beginning to get unfontified text properties. + (sldb-inspect-condition): New command. + (sldb-insert-locals): The :symbol property is now called :name. + Fix locals with :id attribute. + (slime-open-inspector): Fix the bugs I introduced last time. + + * swank.lisp (safe-condition-message): New function. + (debugger-condition-for-emacs): Used to be + format-condition-for-emacs in each backend. Separate the + condition message from the type description. Update all backends + accordingly. + (print-with-frame-label): New function. + + * slime.el (slime-hyperspec-lookup): New function. + +2004-01-02 Wolfgang Jenkner wjenkner@inode.at + + * swank-clisp.lisp: New file. Merged with Vladimir's version. + + * xref.lisp: New file. Used by swank-clisp. + + * swank-loader.lisp (user-init-file): Add CLISP files. + + * swank.lisp (eval-region, tokenize-completion): Modify loops a + bit to make CLISP happy. + + * swank-backend.lisp (with-compilation-hooks): Replace () with + (&rest _) to make CLISP happy. + + * slime.el (slime-goto-source-location): Support for CLISP style + line numbers. Split it up. + (slime-goto-location-buffer, slime-goto-location-position): New + functions. + (slime-load-system): Use slime-display-output-buffer. + (slime-repl-mode): Disable conservative scrolling. Not sure if it + was a good idea. + (sldb-insert-frames, sldb-show-frame-details, sldb-list-locals): + Minor fixes. + (sldb-insert-locals): Renamed from sldb-princ-locals. + (sldb-invoke-restart): Use slime-eval instead of + slime-oneway-eval, because interactive restarts may read input. + (slime-open-inspector): Minor indentation fixes. + (slime-net-output-funcall): Removed. Was unused. + +2003-12-19 Alan Ruttenberg alanr-l@mumble.net + * slime.el 1.157 + fix bug in sldb-princ-locals I introduced when adding fonts to sldb + +2003-12-19 Alan Ruttenberg alanr-l@mumble.net + * swank-openmcl.lisp 1.42 + in request-loop register output stream to be periodically slushed per Gary Byer's email. + * slime.el 1.156 + slime-goto-source-location. Sometimes source information is recorded but it isn't a standard "def" + in that case, don't error out, just look for the most likely place for the definition. + +2003-12-19 Luke Gorrie luke@bluetail.com + + * null-swank-impl.lisp: Deleted this old file. See + swank-backend.lisp instead. + +2003-12-18 Alan Ruttenberg alanr-l@mumble.net + * swank-openmcl.lisp 1.41 + in openmcl (break) now goes into slime debugger. + (setq swank:*break-in-sldb* nil) to disable that. + +2003-12-17 Alan Ruttenberg alanr-l@mumble.net + * slime.el 1.155 + Allow font choices for backtrack. Add group for customizing them: sldb. + Whole thing is enabled with sldb-enable-styled-backtrace which is off by default, for now. + Try + '(sldb-condition-face ((t (:foreground "DarkSlateGray" :weight bold)))) + '(sldb-detailed-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2)))) + '(sldb-local-name-face ((t (:weight bold)))) + '(sldb-restart-face ((t (:foreground "DarkBlue" :weight bold)))) + '(sldb-restart-number-face ((t (:underline t :weight bold)))) + '(sldb-restart-type-face ((t (:foreground "DarkSlateGrey" :weight bold)))) + '(sldb-section-face ((t (:weight bold :height 1.2)))) + '(sldb-selected-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2)))) + '(sldb-topline-face ((t (:foreground "brown" :weight bold :height 1.2)))) + +2003-12-17 Alan Ruttenberg alanr-l@mumble.net + * slime.el 1.154 + Allow some face choices in the inspector. Try + '(slime-inspector-label-face ((t (:weight bold)))) + '(slime-inspector-topline-face ((t (:foreground "brown" :weight bold :height 1.2)))) + '(slime-inspector-type-face ((t (:foreground "DarkRed" :weight bold)))) + You can also set slime-inspector-value-face + +2003-12-17 Alan Ruttenberg alanr-l@mumble.net + + * swank-openmcl.lisp 1.40 + Fix an error with frame-source-location-for-emacs when the + function was a method-function. + Defined method-source-location that handles this case. You can + still end up looking at the wrong definition, as the protocol + doesn't allow passing back the qualifiers and specializers to look + up the correct one in the file + +. * swank-openmcl.lisp 1.39 + Allow you to continue after interrupting. + Properly set *swank-debugger-stack-frame* when interrupting. + + * slime.el 1.152 + sldb-continue now uses slime-oneway-eval + +2003-12-17 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: Better handling of asynchronous output. + (slime-output-end): New variable. Use this marker to insert + output. Insert asynchronous output inserted before the "input + region" and before the prompt. + (slime-show-last-output): Use it. + (slime-repl-insert-prompt): Initialize it. + (slime-last-output-start): Removed. + (slime-flush-output): Increase delay to 20 usecs. + (slime-with-output-end-mark): Renamed from + slime-with-output-at-eob. Insert a newline if needed. + (slime-output-string, slime-repl-activate): Use it. + (slime-repl-return): Ensure that slime-repl-input-end-mark points + to a reasonable location. + +2003-12-17 Luke Gorrie luke@bluetail.com + + * HACKING: New file summarising our way of working. + +2003-12-16 Luke Gorrie luke@bluetail.com + + * slime.el (slime-lisp-preferred-package-nicknames): Removed. Not + very interesting (and slightly broken) now that shortest-nicknames + are automatically used. + (slime-output-oneway-evaluate-request): New function to evaluate + an expression for side-effects (without getting a + result). + (slime-idle-state): Handle new :emacs-evaluate-oneway. + (slime-debugging-state): Handle :emacs-evaluate-oneway. + (sldb-invoke-restart): Use slime-oneway-eval. This avoids pushing + an evaluating state (which will be aborted, and print an unnecessary + message saying so). + (sldb-break-with-default-debugger): New command to break into the + default TTY debugger. Bound to 'B' in *sldb*. + (slime-read-string-state): Added :emacs-evaluate-oneway. + + * swank.lisp (invoke-nth-restart-for-emacs): Wrapper around + INVOKE-NTH-RESTART that checks that Lisp and Emacs agree on the + debug level. This detects and ignores old restart requests when + several are sent at once (possible because of new oneway-eval + feature). + (oneway-eval-string): New function to evaluate a string without + sending a result, and with *DEBUGGER-HOOK* bound to NIL. (The + debugger hook is inhibited to avoid state conflicts.) + +2003-12-15 Luke Gorrie luke@bluetail.com + + * swank-openmcl.lisp (ccl::*warn-if-redefine-kernel*): Support for + interrupting the listener (by Alan Ruttenberg). + +2003-12-15 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp *start-swank-in-background*: Set to t by default. + + * slime.el (slime-eval-last-expression-display-output): New + command. Bound to C-x M-e. Suggested by Nicolas Neuss. + (slime-display-output-buffer): New function. + (slime-slime-compile-file): Use it. + +2003-12-15 Luke Gorrie luke@bluetail.com + + * swank.lisp (*processing-rpc*, *multiprocessing-enabled*, + *debugger-hook-passback*): New variables. + (with-conversation-lock, with-I/O-lock): New macros. + (read-next-form): Use with-I/O-lock. + (send-to-emacs): Use with-I/O-lock. + (swank-debugger-hook): When called asynchronously (i.e. not + during RPC) and multiprocessing is enabled, suspend until + acknowleged by Emacs. + (install-global-debugger-hook): Install a SLIME-DEBUGGER-FUNCTION + globally on *DEBUGGER-HOOK*. + (startup-multiprocessing-for-emacs): Called to initialize multiprocessing. + (eval-string): Dynamically set the *PROCESSING-RPC* flag. + (eval-string): Nasty hack with *DEBUGGER-HOOK-PASSBACK* to + install debugger hook. Temporary, I swear! + (eval-region, shortest-package-nickname): Report the shortest + package nickname to Emacs (for the REPL prompt). Patch from Marco + Baringer. + + * swank-backend.lisp: Defined multiprocessing interface. + + * swank-cmucl.lisp: Implmemented the multiprocessing interface. + + * slime.el (slime-multiprocessing): When true, use + multiprocessing in Lisp if available. + (slime-global-debugger-hook): When true, globally set + *debugger-hook* to use the SLIME debugger. For use with + SERVE-EVENT and multiprocessing. + (slime-handle-oob): Handle :AWAITING-GOAHEAD message from threads + that have suspended to wait for Emacs's attention. + (slime-give-goahead): New command to allow a suspended thread to + continue (bound to RET in the thread-control-panel). + (slime-thread-control-panel): New command to display a buffer + showing all threads that are suspending waiting for Emacs's + attention. Bound to `C-c C-x t'. + (slime-popup-thread-control-panel): When true, automatically + popup the thread-control buffer when a new thread suspends. + +2003-12-14 Alan Ruttenberg alanr-l@mumble.net + + * swank-openmcl.lisp (eval-in-frame, inspect-object and friends): + Most of this is copied from swank-cmucl. The parts between &&&&& + are what I added for openmcl. I piggyback off the inspector which + is shipped with openmcl, so inspecting won't look the same as it + would in cmucl, I imagine. Still, it's a start. eval in frame + uses frame-locals to get bindings so if you have debug settings + low or don't have *save-local-symbols* set you won't be able to + evaluate. + +2003-12-14 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-lispworks.lisp (tracedp, toggle-trace-fdefinition): Moved + to swank.lisp. + + * swank-allegro.lisp (create-swank-server): Add support for + BACKGROUND and CLOSE argument. + (call-with-debugging-environment): Use excl::int-newest-frame to + avoid the kludge with *break-hook*. + (sldb-abort): New function. + (frame-source-location-for-emacs): Dummy definition. + (compile-file-for-emacs): The argument is called + :load-after-compile and not :load. + (xref-results-for-emacs): Use dolist instead of loop. + + * swank-openmcl.lisp (create-swank-server): Add support for + BACKGROUND and CLOSE argument. + (open-stream-to-emacs): Support for dedicated output stream. + + * swank.lisp: *start-swank-in-background*, + *close-swank-socket-after-setup*, *use-dedicated-output-stream*: + Moved here from swank-cmucl. + (sldb-continue): Don't pass the condition as argument, because + that doesn't work with Allegro. + (toggle-trace-fdefinition, tracedp): Replace backend specific code + with portable, but ugly, calls to eval. + + * swank-cmucl.lisp (compile-system-for-emacs): Add method for + CMUCL. + + * slime.el (slime-goto-source-location): Better regexp for package + qualified symbols. Allow dashes in the name and two colons. + Reported by Alan Ruttenberg. + +2003-12-13 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-openmcl.lisp (create-swank-server): Interrupt the right + thread. Patch by Alan Ruttenberg. Not yet enabled, due to lack + of test platform. + (sldb-disassemble): Implement sldb-disassemble command. Patch by + Alan Ruttenberg. + Remove #' from lambdas. + +2003-12-12 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp (create-swank-server): New keyword arguments to + control the server: BACKGROUND and CLOSE. fd-handlers are used if + BACKGROUND is true. If close CLOSE is true, close the socket + after the first connection; keep it open otherwise. + *start-swank-in-background*, *close-swank-socket-after-setup*: The + default values of the corresponding arguments for + create-swank-server. + (compile-file-for-emacs): Don't load the fasl-file when the + compilation failed. + + * swank-openmcl.lisp (toggle-trace-fdefinition, tracedp): + Implement trace command. Patch by Alan Ruttenberg. + (find-function-locations, find-source-locations): Handle + variables, and method-combinations. General cleanups. + (source-info-first-file-name): Removed. + (list-callers): Fixed. + (list-callers): Fixed some more. method-name is not exported in + 0.14. From Marco Baringer. + (swank-accept-connection): Accept multiple connections. Patch by + Marco Baringer. + + * swank-loader.lisp (user-init-file): Use homedir's truename. + Reported by Friedrich Dominicus. + + * slime.el (slime-repl-current-input): Don't remove the final + newline if we are in reading state. + (slime-goto-source-location): Regex-quote the function-name and + handle package prefixes. Reported by Alan Ruttenberg. + (slime-output-string): Insert asynchronous output before the + prompt. + +2003-12-12 Daniel Barlow dan@telent.net + + * swank-source-path-parser.lisp: new file, excerpting part of + swank-cmucl.lisp to where SBCL can find it as well. + +2003-12-11 Luke Gorrie luke@bluetail.com + + * slime.el (slime-one-line-ify): New function to convert + multi-line strings to one-liners by replacing any newline + followed by indentation by a single space. + (slime-xrefs-for-notes): Use it. + +2003-12-11 Daniel Barlow dan@telent.net + + * swank-sbcl.lisp (compiler-note-location): replace with + thinly-ported version from the CMUCL backend which understands + :lisp as a pathname + + * slime.el (slime-xrefs-for-notes): a little more temporary + variables, a little less cdr. Should be slightly faster on + big systems + (slime-goto-next-xref): set window point as well as buffer point - + now works in GNU Emacs 21.2.1 + + * swank.lisp (swank-compiler): new function abstracts commonality + between swank-compile-{file, string}. + (swank-load-system): call swank-compiler to load asdf system + + * swank-sbcl.lisp (compiler-note-location and elsewhere): + remove all trace of *compile-filename* + (compile-*-for-emacs): shorten + + * swank-backend.lisp (call-with-compilation-hooks): new GF + should set up all appropriate error condition loggers etc + to do a compilation preserving the notes. Implement for + sbcl, cmucl + + * slime.el (slime-find-asd, slime-load-system): new command + to compile and load an ASDF system with all the usual compiler + notes and stuff + (slime-compilation-finished): if more than one file has new + errors/notes, create an xref buffer to show them all + (slime-remove-old-overlays): bug fix: now removes overlays even + at start of buffer + (slime-overlay-note): do nothing quietly if + slime-choose-overlay-region returns nil + (slime-choose-overlay-region): return nil if note has no location + +2003-12-11 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-repl-previous-prompt, slime-repl-next-prompt): + New commands. Suggested by H�kon Alstadheim. + (slime-repl-beginning-of-defun, slime-repl-end-of-defun): New + commands. Suggested by Andreas Fuchs. + (slime-repl-insert-prompt): Mark the prompt with a + slime-repl-prompt text property. + (slime-repl-eol): New function. Mostly for symmetry. + (slime-repl-in-input-area-p, slime-repl-at-prompt-end-p): New + predicates. + (slime-repl-find-prompt, slime-search-property-change-fn): New + functions. + (slime-ir1-expand): New command. + + * swank-cmucl.lisp (accept-connection, request-loop): Don't use + fd-handlers. The code for the request-loop itself is now almost + the same as in the Allegro version. + (print-ir1-converted-blocks, expand-ir1-top-level): New functions. + +2003-12-10 Daniel Barlow dan@telent.net + + * swank-sbcl.lisp (serve-request): more fiddling with serve-event + descriptors + + * slime.el (slime-repl-return): slime-check-connected, otherwise + pressing Return in an unconnected repl gets a bit weird + +2003-12-10 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-allegro.lisp, swank-lispworks.lisp, swank-openmcl.lisp, + swank-sbcl.lisp (create-swank-server): Accept an announce-function + keyword argument. + + * swank.lisp (start-server): Pass an announce callback function to + create-swank-server. Works better with single threaded + implementations. + (announce-server-port, simple-announce-function): New functions. + (alistify): Doc fix. + + * swank-cmucl.lisp (create-swank-server): Use announce callback. + (sldb-disassemble): New function. + + * slime.el (sldb-disassemble): New command. Bound to D. + +2003-12-08 Luke Gorrie luke@bluetail.com + + * swank-cmucl.lisp (*debug-definition-finding*): Now nil by + default, so that errors while looking for definitions are printed + as a message and not debugged. + + * slime.el (slime-read-from-minibuffer): Now the only + completing-read function, stale ones deleted. + +2003-12-07 Luke Gorrie luke@bluetail.com + + * slime.el (sldb-prune-initial-frames): Use regexp-heuristics and + the '--more--' token to avoid showing the user Swank-internal + backtrace frames initially. + (slime-repl-current-input): Don't include the final newline + character, to make backtraces prettier. + (slime-autodoc): Fixed annoying case where autodocs would be + fetched in a loop for undocumented symbols. + + * swank.lisp (compound-prefix-match): New name and rewritten for + speed. Completion is much faster now. + (*sldb-initial-frames*): Send up to this many (default 20) + backtrace frames to Emacs when entering the debugger. + +2003-12-07 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-allegro.lisp, swank-backend.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp + (function-source-locations): Make it at generic function. + (function-source-location-for-emacs): Removed. Fixes bug reported + by Marco Baringer. + + * slime.el (slime-interactive-eval): Insert the result at point, + if called with prefix argument. + +2003-12-06 Luke Gorrie luke@bluetail.com + + * slime.el (slime-easy-menu): Added menubar support, contributed + by Friedrich Dominicus. + +2003-12-06 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-allegro.lisp: New file. + + * swank-loader.lisp (user-init-file): Translate logical + pathnames. Reported by Friedrich Dominicus. + + * swank-sbcl.lisp (handle-notification-condition): Don't ignore + warnings without context. + (compiler-note-location, brief-compiler-message-for-emacs, + compiler-note-location): Handle null context. + (compile-file-for-emacs): Bind *compile-filename* and load the + fasl file only if it exists. + (function-source-location): The name argument is now optional and + should be a symbol. + (find-function-locations): Return errors as a list of one error. + (call-with-debugging-environment): Set *print-level* to 4 and + *print-length* to 10. (Both where nil.) + (source-location-for-emacs): Fall back to the location of the + function, if there is no debug-block-info. + (safe-source-location-for-emacs): Don't catch all conditions; only + errors. + *compile-filename*: New variable + (open-listener): Don't make the socket non-blocking. + + * slime.el (slime-eval/compile-defun-dwim): New command. + Suggested by "jan" janmar@iprimus.com.au. + +2003-12-04 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-debugging-state): Don't set sldb-level after + sldb-setup. Breaks the test-suite. + (slime-eval-defun): Fix typos. + (slime-xref-buffer, slime-goto-next-xref): Updated for the new + xref code. + (sldb-inspect-in-frame): Query with the sexp at point as initial + value. + (sldb-step): New command. Bound to s. + + * swank-cmucl.lisp (format-frame-for-emacs, compute-backtrace, + backtrace): Don't send CMUCL's frame numbers to Emacs, use our own + numbering. + (set-step-breakpoints, sldb-step): Lisp side of sldb-step command. + +2003-12-04 Luke Gorrie luke@bluetail.com + + * hyperspec.el: Updated URL to point to a live copy of the + hyperspec at lispworks.com, because the one on xanalys.com has + disappeared. Patch from Vincent Arkesteijn on the ilisp-devel + mailing list. + +2003-12-04 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-lispworks.lisp (toggle-trace-fdefinition, tracedp): New + support functions for toggle-trace command. Written by Alain + Picard. + (compile-from-temp-file): Don't delete the binary file if there is + none. + (lispworks-severity): Map all ERRORs to :error. + + * slime.el (slime-eval-defun): Use slime-re-evaluate-defvar if the + defun starts with "defvar". C-M-x in elisp does this too. + (slime-re-evaluate-defvar): Take the form as argument. + +2003-12-03 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-debugging-state): Initialize the sldb-buffer if + (/= sldb-level level). + (slime-who-specializes): New command. + + * swank-cmucl.lisp (create-swank-server): Set reuse-address to t + by default. + (resolve-note-location): Add method for warnings in interpreted + code. + (who-specializes): New function. + (dd-source-location): Handle case without constructors more + correctly. + (source-path-source-position): Skip ambigous entries in + source-map. + (source-location-from-code-location): Simplified. + +2003-12-03 Luke Gorrie luke@bluetail.com + + * slime.el (slime-completing-read-internal): Fix from Sean + O'Rourke. + +2003-12-02 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-sbcl.lisp (find-function-locations): Return a non-empty + list of source locations. + + * slime.el (slime-with-xref-buffer): Remove spurious comma. (Bug + reported by Raymond Wiker). Some reordering of the xref code. + + * swank.lisp (documentation-symbol): New optional argument for + return value if the symbol is not documented. + +2003-12-02 Sean O'Rourke sorourke@cs.ucsd.edu + + * slime.el: (slime-repl-{clear-buffer,clear-output}): clear the + last and entire output in the *slime-repl* buffer + (slime-documentation): pop up a buffer with a symbol's + documentation instead of its description, if found. + (slime-complete-symbol): tweak the completion, taken from ilisp, to + complete filenames inside strings. + (slime-set-default-directory): also set *slime-repl*'s + default-directory, so e.g. find-file makes sense. + +2003-12-02 Daniel Barlow dan@telent.net + + * slime.el (slime-with-xref-buffer): moved further up the file so + it's defined before slime-show-xrefs needs it + + * swank-sbcl.lisp (function-source-location-for-emacs): return a + list of source locations (one per method) when the request is + for a GF. This seems to make the elisp side popup a window + to let the user select one. Cool. + +2003-12-01 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-[cmucl,sbcl,openmcl,lispworks].lisp (invoke-nth-restart): + Use invoke-restart-interactively. + + * slime.el (slime-create-note-overlay, slime-sexp-depth): The + 'priority' property is unused. Remove it. + + * swank-openmcl.lisp (find-function-locations): Return all methods + for generic functions. Doesn't work very well if multiple methods + are in the same file. + (swank-accept-connection): Don't create an extra thread, call + request-loop directly. + +2003-12-01 Luke Gorrie luke@bluetail.com + + * slime.el (slime-repl-return): Goto end of input area before + inserting newline. + (slime-autodoc-message-ok-p): Test to see if a documentation + message should be printed (returns nil if the + minibuffer/echo-area is already being used). + (slime-symbol-at-point): Skip back over whitespace before + looking for the symbol. + (slime-autodoc-delay): New configurable to specify the delay + before printing an autodoc message (default 0.2 secs). + (slime-ensure-typeout-frame): New function to call create a + typeout frame unless it already exists. Suitable to run on + slime-mode-hook if you always want to have a typeout window. + (slime-log-events): When nil, don't log events to + *slime-events*. This works-around a problem Raymond Toy has when + starting SLIME under XEmacs. Still investigating.. + +2003-11-29 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: Rewrite the xref code to work with other source + locations. + (slime-edit-fdefinition): Use the xref window to display generic + functions with methods. + (slime-goto-source-location): New representation for source + locations. Drop old code. + (slime-list-callers, slime-list-callees): Use the xref window. + Remove the slime-select-* stuff. + (slime-describe-function): New command. Bound to C-c C-f. + Primarily useful in Lispworks. + (slime-complete-symbol): Display the completion window if the + prefix is complete but not unique. + (slime-forward-positioned-source-path): Enter the sexp only if the + remaining sourcepath is not empty. + (slime-read-symbol-name): New optional argument QUERY forces + querying. + + * swank.lisp (group-xrefs): Handle unresolved source locations. + (describe-symbol): Print something sensible about unknown symbols. + + * swank-cmucl.lisp: Use the new format for source locations. + (find-function-locations): New function. Replaces + function-source-location-for-emacs. Returns a list of + source-locations. + (resolve-note-location): Renamed from resolve-location. + Simplified. + (brief-compiler-message-for-emacs): Print the source context + (that's the thing after ==>). + (who-xxxx): Take strings, not symbols, as arguments. + (function-callees, function-callers): Use the same format as the + who-xxx functions. Support for byte-compiled stuff. + (code-location-stream-position): Try to be clever is the source + path doesn't match the form. + (call-with-debugging-environment): Bind *print-readably* to nil. + + * swank-lispworks.lisp: Use the new format for source + locations. Implement the find-function-locations. + (list-callers, list-callers): New functions. + + * swank-sbcl.lisp, swank-openmcl.lisp: Use the new format for + source locations and implement find-function-locations (just calls + the old code). + +2003-11-29 Daniel Barlow dan@telent.net + + * swank-sbcl.lisp (source-location-for-emacs): + sb-debug::print-description-to-string takes only two args, not + three. Now 'v' command works in sldb :-) + + * slime.el (slime-idle-state): added :debug as a valid transition + + * swank.lisp (slime-debugger-function): New. Returns a function + suitable for use as the value of *DEBUGGER-HOOK* to install the + SLIME debugger globally. Must be run from the *slime-repl* buffer + or somewhere else that the slime streams are visible so that it + can capture them. e.g. for Araneida: + PKG> (setf araneida:*restart-on-handler-errors* + (swank:slime-debugger-fucntion)) + +2003-11-29 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: Some tweaking to the REPL. slime-repl-input-end-mark + is now always left inserting and slime-mark-input-end + "deactivates" the end mark by moving it to the beginning of the + buffer. + (slime-goto-source-location): Next try for more uniform + source-locations. A source-location is now a structure with a + "buffer-designator" and "position-designator". The buffer-designator + open the file or buffer and the position-designator moves point to the + right position. + (slime-autodoc-mode): New command. + (slime-find-fdefinitions): Experimental support for generic functions + with methods. + (slime-show-xrefs, slime-insert-xrefs, slime-goto-xref): Rewritten to + work with more general source locations. + + * swank.lisp: Structure definitions for source-locations. + (alistify, location-position<, group-xrefs): Utilities for xref + support. + + * swank-cmucl.lisp (code-location-source-location): Renamed from + safe-source-location-for-emacs. + (code-location-from-source-location): Renamed from + source-location-for-emacs. + (find-fdefinitions, function-source-locations): New functions. + (safe-definition-finding): New macro. + + * swank-lispworks.lisp: Xref support. + (make-dspec-location): Updated for the new source-location format. + +2003-11-29 Luke Gorrie luke@bluetail.com + + * slime.el (complete-symbol, arglist): Updated test cases for new + completion interface. + +2003-11-28 Luke Gorrie luke@bluetail.com + + * slime.el (slime-complete-symbol): Use the new completion + support from the Lisp side. Don't obscure minibuffer input with + completion messages. + + * completer.el: Dead and buried! Replaced by half a page of Common + Lisp. Thanks Bill Clementson for a motivational and well-deserved + taunt. + + * swank.lisp (longest-completion): Compute the best partial + completion for Emacs. + + * slime.el (slime-swank-port-file): Try (temp-directory), + temporary-file-directory, or "/tmp/", depending on what + is (f)bound. + +2003-11-28 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-lispworks.lisp (make-dspec-location): Handle logical + pathnames. Reported by Alain Picard. + + * swank-sbcl.lisp, swank-cmucl.lisp: Support for output + redirection to an Emacs buffer via a dedicated network stream. + Can be enabled with *use-dedicated-output-stream*. + + * swank.lisp (slime-read-string, eval-string): Flush *emacs-io*. + (eval-in-emacs): New function. + + * slime.el: Support for output from a dedicated socket. + (slime-open-stream-to-lisp, slime-output-filter): New functions. + Reorganized REPL code a bit. + (slime-input-complete-p): Use vanilla forward-sexp, because + slime-forward-sexp sometimes caused endless loops. + (slime-disconnect): Close the output-stream-connection if present. + (slime-handle-oob): A new :%apply event. Executes arbitrary code; + useful for bootstrapping. + (slime-flush-output): New function. + (slime-symbol-end-pos): Didn't work at all in Emacs20. Just use + point until someone commits a proper fix. + Various uses of display-buffer: The second argument is different in + XEmacs. + (interrupt-bubbling-idiot): Reduce the timeout to 5 seconds. + +2003-11-27 Luke Gorrie luke@bluetail.com + + * slime.el (slime-swank-port-file): Use `temporary-file-directory' + instead of hardcoding "/tmp/". + +2003-11-27 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-lispworks.lisp: New backend. + + * slime.el (slime-with-output-to-temp-buffer): Save the window + configuration in a buffer local variable instead on a global + stack. + (slime-show-last-output): Behavior customizable with + slime-show-last-output-function. Various tweaking for better + multi-frame support. + + * swank-backend.lisp: List exported symbols explicitly. + + * swank-cmucl.lisp (function-source-location): Better support for + generic functions. + + * swank.lisp (briefly-describe-symbol-for-emacs): Don't return + unbound symbols. + (describe-symbol, describe-function): Support package-qualified + strings. + + * swank-loader.lisp: *sysdep-pathnames*: Add Lispworks files. + (compile-files-if-needed-serially): Compile all files in a + compilation unit. + +2003-11-27 Luke Gorrie luke@bluetail.com + + * slime.el (slime-complete-symbol): Make a bogus alist out of the + completion set, for compatibility with XEmacs. + + * completer.el: Stolen^Wimported from ILISP version 1.4. This is + one revision prior to their latest, where they added a (require) + for some other ILISP code. I backed down a revision to make it + stand-alone, but this may mean that putting SLIME in the load-path + before ILISP will break ILISP. So, beware. + (completer-message): Cut dependency on undefined ilisp constant + testing for xemacs. + +2003-11-27 Zach Beane xach@xach.com + + * swank.lisp (completions): Complete compound symbols (see below). + + * slime.el (slime-complete-symbol): Use `completer' package to + handle more sophisticated completions. This includes abbreviations + like "m-v-b" => "multiple-value-bind". It also (somewhat scarily) + redefines other standard Emacs completion functions with similar + capabilities. See commentary in completer.erl for details. + +2003-11-25 Luke Gorrie luke@bluetail.com + + * slime.el (slime-make-typeout-frame): New command to create a + frame where commands can print messages that would otherwise go to + the echo area. + (slime-background-message): Function for printing "background" + messages. Uses the "typeout-frame" if it exists. + (slime-arglist): Print arglist with `slime-background-message'. + (slime-message): Use typeout frame if it exists, but only for + multi-line messages. + +2003-11-25 Daniel Barlow dan@telent.net + + * swank-sbcl.lisp: delete big chunk of leftover commented-out + code + + * slime.el: arglist command to use slime-read-symbol-name, + not slime-read-symbol + + * README: Minor updates for currency + +2003-11-24 Luke Gorrie luke@bluetail.com + + * swank-backend.lisp (compiler-condition): Removed use of + :documentation slot option. That is not portable (to CMUCL 18e). + + * swank.lisp (eval-string-in-frame): Fixed symbol-visibility + problem (thanks Lawrence Mitchell). + + * swank-sbcl.lisp (function-source-location): Use TRUENAME to + resolve source file name (thanks Lawrence Mitchell). + + * slime.el (slime-goto-source-location): Fixes when finding + definition by regexp: open the right file (was missed), and + tweaked regexp to match more 'def' forms - especially + `defmacro-mundanely' (hyphen wasn't allowed before). + +2003-11-23 Luke Gorrie luke@bluetail.com + + * slime.el (sldb-fetch-more-frames): Call swank:backtrace instead + of (renamed) swank:backtrace-for-emacs. + + * swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl-lisp: Updated + to use new debugger interfaces in swank-backend.lisp. + + * swank-backend.lisp (backtrace, eval-in-frame, frame-catch-tags, + frame-locals, frame-source-location-for-emacs): More interface + functions. + + * slime.el (slime-goto-source-location): Added optional `align-p' + argument for :file and :emacs-buffer location types. This is for + OpenMCL - unlike CMUCL its positions are not character-accurate so + it needs to be aligned to the beginning of the sexp. + (slime-connect): Don't delete a random window when *inferior-lisp* + isn't visible. + + * swank-cmucl.lisp: Tidied up outline-minor-mode structure and + added comments and docstrings. + + * swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl-lisp: Updated + to use new debugger interface in swank-backend.lisp. + + * swank-backend.lisp (call-with-debugging-environment, + sldb-condition, debugger-info-for-emacs): More callbacks defined. + + * swank.lisp: Tidied up outline-minor-mode structure, added + comments and docstrings. + (sldb-loop): Took over the main debugger loop. + + * swank-openmcl.lisp: Updated after refactoring of other backends + (was broken). + + * slime.el (slime-goto-source-location): Align at beginning of + sexp after (:file name pos) and (:emacs-buffer buffer pos). + + * swank-sbcl.lisp (describe-symbol-for-emacs): Don't ask for + (documentation SYM 'class), CLHS says there isn't any 'class + documentation (and SBCL warns). + + * swank.lisp, swank-cmucl.lisp, swank-sbcl.lisp: Refactored + interface through swank-backend.lisp for: swank-compile-file, + swank-compile-string, describe-symbol-for-emacs (apropos), + macroexpand-all, arglist-string. + + * swank-backend.lisp: New file defining the interface between + swank.lisp and the swank-*.lisp implementation files. + +2003-11-22 Brian Mastenbrook bmastenb@cs.indiana.edu + + * swank.asd: ASDF definition to load "swank-loader.lisp". This is + useful for starting the Swank server in a separate Lisp and later + connecting with Emacs. The file includes commentary. + +2003-11-22 Luke Gorrie luke@bluetail.com + + * slime.el (slime-connect): Slightly reordered some window + operations to ensure that *slime-repl* is popped up after `M-x + slime-connect'. + (slime-show-last-output): If the *slime-repl* buffer is already + visible in any frame, don't change anything. + + * swank.lisp (listener-eval): Format results in *buffer-package*. + Exporting (CREATE-SWANK-SERVER <port>). This function can be + called directly to start a swank server, which you can then + connect to with `M-x slime-connect'. It takes a port number as + argument, but this can be zero to use a random available port. + The function always returns the actual port number being used. + +2003-11-19 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp: Better printing off return values. In the REPL + buffer we print now every value in a separate line and in the echo + area separated by a comma. We also print "; No value" for the + degenerated case (values). A new variable *sldb-pprint-frames* + controls the printing of frames in the debugger. (Thanks Raymond + Toy for the suggestions.) + + * swank-cmucl.lisp (format-frame-for-emacs): Bind *pretty-print* + to *sldb-pprint-frames*. + + * slime.el: Window configuration are now saved on a stack, not in + a single global variable. + (slime-with-output-to-temp-buffer) We use now our own version of + with-output-to-temp-buffer. The default version is painfully + incompatible between Emacs versions. The version selects the + temporary buffer and the behaivor of "q" is now more consistent + (as suggested by Jan Rychter). + (slime-connect): Hide the *inferior-lisp-buffer* when we are + connected. + sldb-mode-map: Bind n and p to sldb-down and sldb-up. + (slime-edit-fdefinition-other-window): New function. Suggested by + Christian Lynbech. + + * swank-loader.lisp (user-init-file): There is now a user init + file (~/.swank.lisp). It is loaded after the other files. + +2003-11-16 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: [slime-keys] Override C-c C-r with slime-eval-region + (reported by Paolo Amoroso). + + * swank-loader.lisp: Compile and load gray stream stuff for SBCL + and OpenMCL. + + * swank-openmcl.lisp, swank-sbcl.lisp: Import gray stream symbols. + (without-interrupts*): New function. + + * swank.lisp (send-to-emacs): Protect the write operations by a + without-interrupts, so that we don't trash the *cl-connection* + buffer with partially written messages. + + * swank-cmucl.lisp (without-interrupts*): New function. + + * swank-gray.lisp (stream-write-char): Don't flush the buffer on + newlines. + + * slime.el: Add some docstring. + (interrupt-bubbling-idiot): New test. + [slime-keys]: Don't bind "\C- ". Problematic on LinuxPPC. + +2003-11-15 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: Some tweaking for better scrolling in the *slime-repl* + buffer (suggested by Jan Rychter). + (slime-compile-file): Display the output buffer at the beginning. + (slime-show-last-output): Include the prompt so that window-point + is updated properly. + (slime-with-output-at-eob): Update window-point if the buffer is + visible. + (slime-state/event-panic): Include the *slime-events* and + *cl-connection* buffers in the report. + + * swank-cmucl.lisp (sos/out): Don't flush the buffer on newlines. + +2003-11-13 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: Imititate an "output-mark". Output from Lisp should + move point only if point is at the end of the buffer. (Thanks + William Halliburton for the suggestion.) + (slime-with-output-at-eob): New function. + (slime-output-string, slime-repl-maybe-prompt): Use it. + + slime-repl-mode-map: Override "\C-\M-x". + + An experimental scratch buffer: + (slime-eval-print-last-expression): New function. + (slime-scratch-mode-map, slime-scratch-buffer, + slime-switch-to-scratch-buffer, slime-scratch): New functions. + + * swank-cmucl.lisp (resolve-location): Emacs buffer positions are + 1 based. Add 1 to the 0 based file-position. + +2003-11-13 Luke Gorrie luke@bluetail.com + + * slime.el (slime-connect): pop-to-buffer into *slime-repl* when + we connect. + +2003-11-13 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el, swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl: New + representation for "source-locations". Compiler notes have now a + message, a severity, and a source-location field. Compiler notes, + edit-definition, and the debugger all use now the same + representation for source-location. CMUCL does the source-path to + file-position translation at the Lisp side. This works better + with reader macros, in particular with backquote. The SBCL + backend still does the translation on the Emacs side. OpenMCL + support is probably totally broken at the moment + +2003-11-13 Luke Gorrie luke@bluetail.com + + * slime.el (slime-repl-previous-input, slime-repl-next-input): + When partial input has already been entered, the M-{p,n} REPL + history commands only match lines that start with the + already-entered prefix. This is comint-compatible behaviour which + has been requested. The history commands also skip over line + identical to the one already entered. + (slime-complete-maybe-restore-window-confguration): Catch errors, + so that we don't cause `pre-command-hook' to be killed. + (slime-truncate-lines): If you set this to nil, slime won't set + `truncate-lines' in buffers like sldb, apropos, etc. + +2003-11-12 Luke Gorrie luke@bluetail.com + + * slime.el (slime-show-description): XEmacs portability: don't use + `temp-buffer-show-hook'. + (slime-inspect): Use `(slime-sexp-at-point)' as default inspection + value (thanks Jan Rychter). + +2003-11-10 Luke Gorrie luke@bluetail.com + + * slime.el (slime-post-command-hook): Inhibit unless (still) in + slime-mode. Only call `slime-autodoc-post-command-hook' when + `slime-autodoc-mode' is non-nil. + (slime-setup-command-hooks): Use `make-local-hook' instead of + `make-local-variable'. + +2003-11-08 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: slime-highlight-face: Use the :inherit attribute if + possible. + (slime-face-inheritance-possible-p): New function. + + * slime.el (slime-repl-return): Only send the current input to + Lisp if it is a complete expression, like inferior-slime-return. + + * swank.lisp (completions): Use *buffer-package* if no other + package is given. + + * slime.el: Remove the non-working face inheriting stuff. + Hardcode colors for slime-highlight-face and specify the :inherit + attribute for slime-repl-output-face. So Emacs21 will do the + right thing and the others get at least a customizable face. + + * slime.el (slime-buffer-package): Try to find be the + package name before resorting to slime-buffer-package. Return nil + and not "CL-USER" if the package cannot be determined. + (slime-goto-location): Insert notes with a source path, but + without filename or buffername, at point. This can happen for + warnings during macro expansion. (The macro expander is a + interpreted function and doesn't have a filename or buffername.) + (slime-show-note): Display 2 double quotes "" in the echo area for + zero length messages. SERIES tends to signal warnings with zero + length messages. + (slime-print-apropos): Add support for alien types. + + * swank-cmucl.lisp (briefly-describe-symbol-for-emacs): Add + support for alien types. + (source-path-file-position): Read the entire expression with a + special readtable. The readtable records source positions for + each sub-expression in a hashtable. Extract the sub-expression + for the source path from the read object and lookup the + sub-expression in the hashtable to find its source position. + + * swank-sbcl.lisp (swank-macroexpand-all): Implemented. + +2003-11-06 Luke Gorrie luke@bluetail.com + + * slime.el (slime-autodoc-mode): When non-nil, display the + argument list for the function-call near point each time the point + moves in a slime-mode buffer. This is a first-cut; more useful + context-sensitive help to follow (e.g. looking up variable + documentation). + (slime-autodoc-cache-type): Cache policy "autodoc" documentation: + either nil (no caching), 'last (the default - cache most recent + only), or 'all (cache everything on symbol plists forever). + + * slime.el: Convenience macros: + (when-bind (var exp) &rest body) + => (let ((var exp)) (when var . body)) + (with-lexical-bindings (var1 ...) . body) + => (lexical-let ((var1 var1) ...) . body) + + * slime.el (slime, slime-lisp-package): Reset `slime-lisp-package' + (the REPL package) when reconnecting. + (slime-buffer-package): Return `slime-lisp-package' when the + major-mode is `slime-repl-mode'. + +2003-11-04 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-read-string-state): Add support for evaluation + requests. + (slime-repl-read-break): New command. + alternative. + slime-keys: XEmacs cannot rebind C-c C-g. Use C-c C-b as an + alternative. + (slime-selector): XEmacs has no prompt argument for read-char. + (slime-underline-color, slime-face-attributes): Make face + definitions compatible with XEmacs and Emacs20. + (slime-disconnect): Delete the buffer of the socket. + (slime-net-connect): Prefix the connection buffer name with a + space to avoid accidental deletion. + + * swank.lisp (slime-read-string): Send a :read-aborted event for + non-local exits. + (case-convert): Handle :invert case better. + +2003-11-03 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-display-message-or-view, + slime-remove-message-window): Display too long lines in a new + window. Add a temporary pre-command-hook to remove the multiline + window before the next command is executed. + + (slime-complete-symbol): Save the window configuration before + displaying the completions and try to restore it later. The + configuration is restored when: (a) the completion is unique (b) there + are no completion. It is also possible to delay the restoration until + (c) certain characters, e.g, space or a closing paren, are inserted. + + (slime-selector): Don't abort when an unkown character is pressed; + display a message and continue. Similiar for ??. Add a selector for + the *sldb* buffer. + + (slbd-hook, sldb-xemacs-post-command-hook): Emulate Emacs' + point-entered text property with a post-command hook. + + * swank.lisp (case-convert, find-symbol-designator): New + functions. + + * swank-cmucl.lisp, swank-openmcl.lisp, swank-sbcl.lisp + (arglist-string): Don't intern the function name. Use + find-symbol-designator instead. + +2003-11-03 Luke Gorrie luke@bluetail.com + + * slime.el (slime-display-buffer-region): Hacked to fix completely + inexplicable XEmacs problems. + +2003-11-2 Helmut Eller e9626484@stud3.tuwien.ac.at + + * null-swank-impl.lisp, swank-cmucl.lisp, swank-openmcl.lisp, + swank.lisp: Input redirection works now on the line level, like a + tty. Output streams are now line buffered. We no longer compute + the backtrace-length. + + * slime.el: + (slime-repl-read-mode, slime-repl-read-string, slime-repl-return, + slime-repl-send-string, slime-read-string-state, + slime-activate-state): Reorganize input redirection. We no longer + work on the character level but on a line or region; more like a + terminal. This works better, because REPLs and debuggers are + usually written with a line buffering tty in mind. + (sldb-backtrace-length, slime-debugging-state, + slime-evaluating-state, sldb-setup, sldb-mode, sldb-insert-frames, + sldb-fetch-more-frames): Don't use backtrace-length. Computing + the length of the backtrace is (somewhat strangely) an expensive + operation in CMUCL, e.g., it takes >30 seconds to compute the + length when the yellow zone stack guard is hit. + +2003-11-02 Luke Gorrie luke@bluetail.com + + * slime.el (slime-log-event): Added a *slime-events* buffer + recording all state machine events. The buffer uses hideshow-mode + to fold messages down to single lines. + (slime-show-source-location): Bugfix: only create source-highlight + overlay if the source was actually located. + (slime-selector): Renamed from `slime-select' because that + function name was already in use. Ooops! + + * swank.lisp (eval-string): force-output on *slime-output* before + returning the result. This somewhat works around some trouble + where output printed by lisp is being buffered too long. + + * slime.el (slime-lisp-package-translations): Association list of + preferred package nicknames, for the REPL prompt. By default maps + COMMON-LISP->CL and COMMON-LISP-USER->CL-USER. + +2003-11-01 Luke Gorrie luke@bluetail.com + + * slime.el (slime-select): Added an extensible "Select" command, + which I gather is a LispM/Martin-Cracauer knock-off. When invoked, + the select command reads a single character and uses that to + decide which buffer to switch to. New characters can be defined, + and the currently availables ones can be seen with '?'. I have not + assigned a key to Select, because it seems like a command that + should have a global binding. I would suggest `C-c s'. + + * swank.lisp (*slime-features*): Variable remembering the FEATURES + list. + (sync-state-to-emacs): Update Emacs about any state changes - + currently this just means changes to the FEATURES list. + (eval-string): Call `sync-state-to-emacs' before sending result. + (eval-region): With optional PACKAGE-UPDATE-P, if the evaluation + changes the current package, tell Emacs about the new package. + (listener-eval): Tell `eval-region' to notify Emacs of package + changes, so that e.g. (in-package :swank) does the right thing + when evaluated in the REPL. + + * slime.el (slime-repl-output-face, slime-repl-input-face): Face + definitions for output printed by Lisp and for previous REPL user + inputs, respectively. Defaulting the input face to bold rather + than underline, because it looks better on multi-line input. + (slime-handle-oob): Two new out-of-band messages + (:new-features FEATURES) and (:new-package PACKAGE-NAME). These + are used for Lisp to tell Emacs about changes to *FEATURES* and + *PACKAGE* when appropriate. + (slime-same-line-p): Better implementation (does what the name + suggests). + (slime-lisp-package): New variable keeping track of *PACKAGE* in + Lisp -- or at least, the package to use for the REPL. + (slime-repl-insert-prompt): The prompt now includes the package + name. + (slime-repl-bol): C-a in the REPL now stops at the prompt. + (slime-repl-closing-return): C-RET & C-M-m now close all open + lists and then send input in REPL. + (slime-repl-newline-and-indent): C-j in REPL is now better with + indentation (won't get confused by unmatched quotes etc appearing + before the prompt). + +2003-11-1 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-debugging-state): Save the window configuration + in a state variable. + sldb-saved-window-configuration: Removed. + (slime-repl-mode): Use conservative scrolling. + (slime-repl-insert-prompt): Set window-point after the prompt. + (slime-repl-add-to-input-history): Don't add subsequent duplicates to + the history. + + * swank.lisp (slime-read-char): Flush the output before reading. + (listener-eval): Like eval region but set reader variables (*, **, + *** etc.) + + * swank-openmcl.lisp, swank-sbcl.lisp: Implement stream-line-column. + + * swank-cmucl.lisp (slime-input-stream-misc-ops): Renamed from + slime-input-stream-misc. + +2003-10-31 Luke Gorrie luke@bluetail.com + + * slime.el (slime-repl-mode-map): Bound `slime-interrupt' on both + C-c C-c and C-c C-g. + + * swank.lisp (interactive-eval): Evaluate in *buffer-package*. + + * slime.el: Tweaked debugger window management somewhat: the + window configuration is saved when the debugger is first entered + and then restored when the idle state is reached. + +2003-10-31 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: (slime-repl-read-mode, slime-repl-read-xxx): New minor + mode for stream character based input to Lisp. + + * swank.lisp: *read-input-catch-tag*, take-input, slime-read-char: + Moved here from swank-cmucl.lisp. + (defslimefun, defslimefun-unimplemented): Move macro definitions to + the beginning of the file. + + * swank-cmucl.lisp: (slime-input-stream, slime-input-stream-read-char, + lime-input-stream-misc): Character input stream from Emacs. + (slime-input-stream/n-bin): Removed. + + * swank-openmcl.lisp, swank-sbcl.lisp: Gray stream based input + redirection from Emacs. + +2003-10-29 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: + Beginnings of a REPL-mode. + Minor debugger cleanups. + + * swank.lisp: + slime-read-error: New condition. + (read-next-form): Re-signal the conditions as slime-read-errors. And + check the result of read-sequence (i.e. detect CMUCL's read-sequence + bug). + (sldb-continue, throw-to-toplevel): Was more or less the same in all + backends. + + * swank-openmcl.lisp, swank-sbcl.lisp, swank-cmucl.lisp: + (serve-request): Handle slime-read-errors and bind a + slime-toplevel catcher. + + * swank-cmucl.lisp: + (sldb-loop): Flush output at the beginning. + (inspect-in-frame): New function. + (frame-locals): Don't send the validity indicator across wire. Too + cmucl specific. + +2003-10-29 Luke Gorrie luke@bluetail.com + + * slime.el (slime-net-sentinel): Only show a message about + disconnection if the inferior-lisp is still running. + (slime-interrupt, slime-quit): Only send the quit/interrupt + message to Lisp if it is in fact evaluating something for us. This + fixes a protocol bug reported by Paolo Amoroso. Added (require + 'pp). + +2003-10-28 James Bielman jamesjb@jamesjb.com + + * null-swank-impl.lisp: New file. + + * swank-openmcl.lisp: Pre-refactoring updates to the OpenMCL backend: + (map-backtrace): Renamed from DO-BACKTRACE. + (frame-source-location-for-emacs): New function. + (function-source-location-for-emacs): New function, + + * swank-openmcl.lisp: Docstring updates/additions. + +2003-10-25 Luke Gorrie luke@bluetail.com + + * Everywhere: Changed the connection setup to use a dynamic + collision-free TCP port. The new protocol is this: + + Emacs calls (swank:start-server FILENAME) via the + listener. FILENAME is /tmp/slime.${emacspid} + Lisp starts a TCP server on a dynamic available port and writes + the port number it gets to FILENAME. + Emacs asynchronously polls for FILENAME's creation. When it + exists, Emacs reads the port number, deletes the file, and makes + the connection. + + The advantage is that you can run multiple Emacsen each with an + inferior lisp, and the port numbers will never collide and Emacs + will always connect to the right lisp. + + All backends are updated, but only CMUCL and SBCL are + tested. Therefore, OpenMCL is almost certainly broken just now. + + * slime.el (inferior-slime-closing-return): New command that + closes all open lists and sends the result to Lisp. Bound to C-RET + and (for people who use C-m for RET) C-M-m. + (inferior-slime-indent-line): Improved indentation in the inferior + list buffer. + +2003-10-24 Luke Gorrie luke@bluetail.com + + * slime.el (inferior-slime-return): Command bound to RET in + inferior-slime-mode: only send the current input to Lisp if it is + a complete expression (or prefix argument is given). Two reasons: + it makes the input history contain complete expressions, and it + lets us nicely indent multiple-line inputs. (Thanks Raymond Toy + for the suggestions.) + +2003-10-23 Luke Gorrie luke@bluetail.com + + * slime.el (slime-maybe-start-lisp): Restart inferior-lisp if the + process has died. + + * swank-sbcl.lisp (accept-connection): Use a character stream to + match swank.lisp. + +2003-10-22 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp (setup-request-handler): Create a character + stream. + (read-next-form): Removed. + + * swank.lisp (read-next-form, send-to-emacs): Assume *emacs-io* is + a character stream. Add the necessary char-code/code-char + conversions. + + * slime.el: slime-keys: Add :sldb keywords for keys useful in the + debugger. + (slime-init-keymaps): Allow allow :sldb keywords. + + inferior-lisp-mode-hook: Display the inf-lisp buffer if there is + some output. + + (slime-process-available-input): Start a timer to process any + remaining input. + (slime-dispatch-event): The timer should take care of any lost + input. So don't process the available input here. Remove the + process-input argument. + (slime-push-state, slime-pop-state, slime-activate-state, + slime-idle-state, slime-evaluating-state): Update callers. + (slime-debugging-state): Remove the unwind-protect in the + :debug-return clause. Should not be necessary. + + sldb-mode-map: Define more slime-mode keys. + + (slime-time<, slime-time-add): Removed. Emacs-21 has equivalent time + functions. + (slime-sync-state-stack): Use Emacs-21 time-date functions. + (seconds-to-time, time-less-p, time-add): Compatibility defuns. + +2003-10-22 Luke Gorrie luke@bluetail.com + + * slime.el (slime): With a prefix argument, prompt for the port + number to use for communication with Lisp. This is remembered for + future connections. + +2003-10-22 Hannu Koivisto azure@iki.fi + + * slime.el (slime-space): Now allows one to insert several spaces + with a prefix argument. + +2003-10-21 Luke Gorrie luke@bluetail.com + + * slime.el (slime-space): Don't give an error when not connected, + to avoid feeping. + + * swank-sbcl.lisp (swank-compile-string): Include only one + :SOURCE-PATH attribute in the plist, and replace the front element + with a 0 (fixes a problem probably due to recent hacks to the + elisp source-path lookups). + + * slime.el (inferior-slime-mode): New minor mode for use with + `inferior-lisp-mode'. Defines a subset of the `slime-mode' keys + which don't clash with comint (e.g. doesn't bind M-{p,n}). + (slime-keys): List of keybinding specifications. + (slime-find-buffer-package): If we don't find the "(in-package" by + searching backwards, then try forwards too. + + * swank.lisp (completions): Fixed semantics: should now consider + only/all completions that would not cause a read-error due to + symbol visibility. Also avoiding duplicates and sorting on + symbol-name. + +2003-10-20 Luke Gorrie luke@bluetail.com + + * swank.lisp (completions): Slight change of semantics: when a + prefix-designator is package-qualified, like "swank:", only match + symbols whose home-package matches the one given - ignore + inherited symbols. + + * slime.el: Updated test suite to work with the different backends: + (find-definition): Lookup definitions in swank.lisp. + (arglist): Lookup arglists of functions in swank.lisp. + +2003-10-20 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (interactive-eval): Make test case independent of + *print-case*. + +2003-10-20 Luke Gorrie luke@bluetail.com + + * swank-cmucl.lisp (clear-xref-info): Conditionalised + xref:*who-is-called* and xref:*who-macroexpands* with + #+CMU19. This makes SLIME compatible with CMUCL 18e, but also + disables the `who-macroexpands' command in any CMUCL version that + doesn't have the "19A" feature (which does break the command in + some snapshot builds that can actually support it). + +2003-10-20 Daniel Barlow dan@telent.net + + * swank.lisp (*notes-database*): tyop fix + + * swank-sbcl.lisp (throw-to-toplevel): select TOPLEVEL restart + instead of throwing to a catch that no longer exists + + * slime.el: change some strings containing 'CMUCL' to more + backend-agnostic phrases + +2003-10-19 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el, swank-cmucl.lisp, swank.lisp: First shoot at input + redirection. + + * swank-sbcl.lisp, swank-openmcl.lisp: Bind *slime-input* and + *slime-io* to dummy values. + +2003-10-19 Luke Gorrie luke@bluetail.com + + * slime.el (slime): Connection setup is now asynchronous, with + retrying on a timer. This makes it possible to bring the server up + by hand while debugging. `M-x slime' while already connected will + cause the old connection to be dropped and a new one established. + (slime-disconnect): New command to disconnect from Swank, or + cancel asynchronous connection attempts when not yet connected. + (slime-state/event-panic): Illegal events in the communication + state machine now trigger a general panic that disconnects from + Lisp, and displays a message describing what has happened. This is + a bug situation. + (slime-connect): Print a message during connection attempts unless + the minibuffer is active (it's annoying to get messages while + trying to enter commands). + +2003-10-18 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: Fix some bugs in the state machine and be a bit more + careful when processing pending input. + (slime-compile-region): New command. + Some more tests. + +2003-10-17 James Bielman jamesjb@jamesjb.com + + * .cvsignore: Add OpenMCL and SBCL fasl file extensions. + + * swank-openmcl.lisp (who-calls): Fix bug where we would try to + take the TRUENAME of NIL when source information isn't available + for a caller. + (backtrace-for-emacs): Clean up the backtrace code a bit in + preparation for implementing FRAME-LOCALS. + (frame-catch-tags): Implement a stub version of this. + (frame-locals): Implemented fully for OpenMCL. + + * swank-loader.lisp (compile-files-if-needed-serially): Be a little + more verbose when compiling files. + +2003-10-17 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp, swank-sbcl.lisp, swank-openmcl.lisp, + swank-cmucl.lisp: Move more stuff to swank.lisp. + +2003-10-17 Luke Gorrie luke@bluetail.com + + * slime.el (slime-post-command-hook): Check that we are connected + before trying to process input. + (slime-net-connect): Handle `network-error' condition for XEmacs + 21.5. (Thanks Raymond Toy.) + + * swank-sbcl.lisp: Report style-warnings separately from notes + (patch from Christophe Rhodes). Use REQUIRE to load sb-introspect + instead of loading the source file (requires the sb-introspect + library to be installed, which doesn't yet happen in the + sourceforge-lagged SBCL anoncvs, but does in the real one). + + * slime.el (slime-style-warning-face): Added style-warnings, which + are between a warning and a note in severity. (Patch from + Christophe Rhodes). + + * test.sh: When the test fails to complete, print "crashed" + instead of reporting nonsense. + +2003-10-17 James Bielman jamesjb@jamesjb.com + + * swank.lisp (apropos-symbols): Change back to using the standard + 2-argument APROPOS-LIST and check symbols explicitly when + EXTERNAL-ONLY is true. + Move loading of sys-dependent backend code into 'swank-loader'. + + * swank-sbcl.lisp: Moved declarations of *PREVIOUS-COMPILER-CONDITION* + into 'swank.lisp' to kill warnings about undefined variables. + + * swank-openmcl.lisp (handle-compiler-warning): Use source position + instead of function name for warning locations. + (swank-compile-string): Compile into a temporary file instead of + using COMPILE so finding warning positions works when using C-c C-c. + (compute-backtrace): Don't display frames without a function. + (apropos-list-for-emacs): Implement APROPOS. + (who-calls): Implement WHO-CALLS. + (completions): Implement COMPLETIONS. + Use NIL instead of zero so FRESH-LINE does the right thing. + + * slime.el (slime-maybe-compile-swank): Removed function---compile + the backend using 'swank-loader.lisp' instead. + (slime-backend): Changed default backend to 'slime-loader'. + (slime-lisp-binary-extension): Deleted as this is no longer needed. + + * swank-loader.lisp: New file. + +2003-10-17 Luke Gorrie luke@bluetail.com + + * slime.el (slime-net-connect): Check that + `set-process-coding-system' is fbound before calling it. This is + needed in the XEmacs I built from sources. + +2003-10-17 Daniel Barlow dan@telent.net + + * swank-sbcl.lisp: Transplanted Helmut's serve-event server to + replace the existing thread-using server. SLIME now has no + dependency on SB-THREAD + + * slime.el (slime-find-buffer-package): handle errors from (read) + for the case where the buffer ends before the in-package form does + (slime-set-package): insert missing comma + (slime-goto-source-location): sbcl has a disagreement with emacs + over the meaning of a character position. Level up with + C-M-f C-M-b + + * assorted typo fixes + +2003-10-16 Luke Gorrie luke@bluetail.com + + * slime.el (slime-forward-source-path): Improved somewhat. Seems + to work for all common cases except backquote. Backquote is + tricky, because the source-paths are based on the reader's + expansion, e.g.: + * (let ((*print-pretty* nil)) + (print (read-from-string "`(a ,@(b c) d)"))) + --> + (COMMON-LISP::BACKQ-CONS (QUOTE A) + (COMMON-LISP::BACKQ-APPEND (B C) + (QUOTE (D)))) + Must investigate whether we need to write a hairy + backquote-traversing state machine or whether this is something + that could be fixed in CMUCL. + + * swank*.lisp (with-trapping-compiler-notes): This macro is now + defined here, and expands to a call to the backend-defined + `call-trapping-compiler-notes' with the body wrapped in a + lambda. This is to avoid swank.lisp referring to macros in the + backends -- it gets compiled first so it thinks they're functions. + + * slime.el (slime-swank-connection-retries): New default value is + `nil', which means unlimited retries (until user aborts). Retry + interval also reduced from once per second to four times per + second. + +2003-10-16 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank-cmucl.lisp, swank.lisp: Fix CMUCL support. + +2003-10-15 Daniel Barlow dan@telent.net + + * swank.lisp: rearrange the backends. rename swank.lisp to + swank-cmucl.lisp, then create new swank.lisp which loads an + appropriate backend according to *features*. Next up, + identify common functions in the backends and move them + into swank.lisp + +2003-10-15 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: Inspector support. list-callers, list-callees + implemented without xref. + + * swank.lisp: Lisp side for inspector and list-callers, + list-calees. Better fdefinition finding for struct-accessors. + + +2003-10-15 Luke Gorrie luke@bluetail.com + + * slime.el (slime-point-moves-p): Macro for executing subforms and + returning true if they move the point. + + * test.sh: New file to run the test suite in batch-mode. Will need + a little extending to allow configuring the right variables to + work with non-CMUCL backends. + + * slime.el: Set `indent-tabs-mode' to nil. This makes diffs look + better. + (slime-start-swank-server): Now passing the port number to + SWANK:START-SERVER. + (slime-evaluating-state): Debugging synchronous evaluations with + recursive edits now works. + (slime-forward-sexp): Added support for #|...|# reader comments. + (sldb-hook): New hook for entry to the debugger (used for the test + suite). + (slime-run-tests): Reworked the testing framework. Now presents + results in an outline-mode buffer, with only the subtrees + containing failed tests expanded initially. + (slime-check): Check-name can now be a string or + format-control. (Test cases have been updated to take advantage of + this.) + (compile-defun): This test case now works for the case containing + #|..|# + (async-eval-debugging): New test case for recursively debugging + asynchronous evaluation. + +2003-10-15 Daniel Barlow dan@telent.net + + * README.sbcl: new file + + * README: update for new backends, change of hosting provider + + * swank-sbcl.lisp: new file. + New SWANK backend for Steel Bank Common Lisp, adapted from + swank.lisp with bits of swank-openmcl.lisp + +2003-10-12 Daniel Barlow dan@telent.net + + * slime.el (sldb-mode-map): add mouse-2 clickability for areas + in sldb buffers covered by the sldb-default-action property: + restarts can now be mouse-activated + +2003-09-28 James Bielman jamesjb@jamesjb.com + + * swank-openmcl.lisp: New file, a Slime backend for OpenMCL 0.14.x. + (condition-function-name): Figure out the name of methods correctly + instead of passing a list to Emacs. + + * slime.el (slime-goto-location): Try to position notes based on + some (questionable) regex searching if the :FUNCTION-NAME property + is set. Used in the OpenMCL backend which does not support source + paths. + +2003-09-29 Luke Gorrie luke@bluetail.com + + * slime.el: Fairly major hacking. + Rewrote the evaluation mechanics: similar design but some macros + to make it look more like a push-down automaton (which it really + was!). Debugging Lisp no longer uses recursive edits, partly as a + side-effect and partly to see if it's better this way. + Removed the asynchronous-communication test cases that tested + something we decided not to do. + (slime-eval-string-async): Give a meaningful error message when + trying to make a request while already busy. + (slime-lisp-binary-extension): Uh oh, time to start taking out + gratuitous CMUCL-isms. This variable renamed from + `slime-cmucl-binary-extension'. + (slime-backend): Name of the Lisp backend file, defaulting to + "swank", but can be set to e.g. "swank-openmcl". + + * swank.lisp: Minor protocol changes to accomodate slime.el's + changes above. + +2003-09-28 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp + (getpid, set-package, set-default-directory): New functions. + (slime-out-misc): Don't send empty strings. + (*redirect-output*, read-from-emacs): A new switch to turn output + redirection off. Useful for debugging. + (interactive-eval, interactive-eval-region, pprint-eval, + re-evaluate-defvar): Bind *package* to *buffer-package*. + (with-trapping-compilation-notes): Add a dummy argument for better + indentation. + (measure-time-intervall, call-with-compilation-hooks): Measure + compilation time. + (frame-locals): Use di::debug-function-debug-variables instead of + di:ambiguous-debug-variables. Don't access non-valid variables. + + * slime.el + (slime-display-message-or-view): Delete old multi-line windows. + (slime-read-package-name): Added an optional initial-value + argument. slime-pid: New variable. + (slime-init-dispatcher): Initialize slime-pid. + (slime-send-sigint): Use slime-pid instead of inferior-lisp-proc. + (slime-eval): Accept debug-condition messages. + (slime-output-buffer): Turn slime-mode on. + (slime-switch-to-output-buffer): New command. Bound to C-c C-z. + (slime-show-note-counts): Display compilation time. + (slime-untrace-all, slime-set-package, slime-set-default-directory + slime-sync-package-and-default-directory): New commands. + (slime-princ-locals): Don't access non-valid variables. This may + cause segfaults and severely confuse CMUCL. + (slime-define-keys): New macro. + +2003-09-28 Luke Gorrie luke@bluetail.com + + * swank.lisp (create-swank-server): Bind the listen-socket on the + loopback interface by default, so that remote machines can't + connect to the Swank server. + +2003-09-27 Luke Gorrie luke@bluetail.com + + * swank.lisp (with-trapping-compilation-notes): New macro for + bindings the handlers to record compiler notes. Now being used in + `compile-string', which I had broken when removing the compilation + hook. + + * slime.el (slime-function-called-at-point): Rewritten to work + better. Now considers "((foo ..." _not_ to be a function call to + foo because of the double ('s - this will keep it from misfiring + in e.g. LET bindings. + (def-slime-test): All tests now being with (slime-sync). This + fixes some accidental/bogus test failures. + + * swank.lisp (handle-notification-condition): Rewrote + compiler-note collection. Now it uses lower-level condition + handlers instead of c:*compiler-notification-function*. This way + the error messages are tailored to omit redundant information, + like the filename and original source text (which are displayed + and highlighted in Emacs already). Much nicer. + (sort-contexts-by-source-path): Now sorting xref results by + lexical source-path order, so that you're always jumping in the + same direction. + (*debug-definition-finding*): New variable. You can set this to + true if you want to be popped into the debugger when M-. fails to + find a definition (for debugging the + definition-finding). Otherwise it reports the error to Emacs as a + message, like "Error: SETQ is a special form." + + * slime.el (slime-fetch-features-list): New command to fetch the + *FEATURES* list from Lisp and store it away. This is done + automatically upon connection, but can also be called manually to + update. + (slime-forward-reader-conditional): Now does the right things with + reader-conditionals (#+ and #-) based on the Lisp features. + +2003-09-26 Luke Gorrie luke@bluetail.com + + * slime.el (sldb-setup): Setting `truncate-lines' to t in the + debug buffer. I like having the backtrace take strictly one line + per frame, since otherwise a few ugly arguments (e.g. streams) can + chew up a lot of space. (Can make this a configurable on request + if tastes differ :-) + + * swank.lisp: Did a little defensive programming so that asking + for the definition of an unbound function will return nil to Emacs + instead of entering the debugger. + (format-frame-for-emacs): Binding *PRETTY-PRINT* to nil when + formatting frames (due to truncate-lines change above). + +2003-09-24 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp: + Support for stream redirection. + slime-output-stream: New structure. + (slime-out-misc): New function. + *slime-output*: New variable. + (read-from-emacs): Redirect output to *slime-output*. + (read-form): Bind *package* inside the standard-io-syntax macro. + (eval-string): Read the string with read-form. + (completions): Support for keyword completion. + + * slime.el (slime-process-available-input, slime-eval): Rewritten + once again. Don't use unwind-protect anymore. Didn't work + properly when the Lisp side aborted due to too many debug + levels. "Continuing" from the Emacs debugger aborts one level on + the Lisp side. "Quitting" from the Emacs debugger quits the Lisp + side too. Increase stack sizes before entering the recursive edit. + (slime-eval-async-state, slime-eval, sldb-state): Support for stream + output. + slime-last-output-start: New variable. + (slime-output-buffer, slime-output-buffer-position, + slime-insert-transcript-delimiter, slime-show-last-output, + slime-output-string): New functions. + (slime-show-evaluation-result, + slime-show-evaluation-result-continuation): Use them. + (slime-use-inf-lisp-p, slime-insert-transcript-delimiter, + slime-inferior-lisp-marker-position, + slime-inferior-lisp-show-last-output): Deleted. + (slime-use-tty-debugger, slime-debugger-hook, + slime-enter-tty-debugger, slime-tty-debugger-state): Deleted. Removed + tty debugger support. + (def-sldb-invoke-restart): Renamed. + (define-sldb-invoke-restart-key, define-sldb-invoke-restart-keys): + Version without eval. + (defun-if-undefined): New macro. + Many indentation fixes. + +2003-09-23 Helmut Eller e9626484@stud3.tuwien.ac.at + + * swank.lisp (completions): + Moved most of the completion code to Lisp. + (string-prefix-p): Be case insensitive. + + * slime.el: + Make sure define-minor-mode is defined before we use it. + (slime-completing-read-internal, slime-completing-read-symbol-name, + slime-read-from-minibuffer, slime-completions, slime-complete-symbol): + Support for reading symbols and expressions with completion. + (slime-read-symbol-name): New function. + (slime-read-symbol): Use it. + (slime-read-package-name): Case insensitive completion. + + (slime-edit-symbol-fdefinition, slime-edit-fdefinition): Rename + slime-edit-symbol-fdefinition to slime-edit-fdefinition. + +2003-09-23 Luke Gorrie luke@bluetail.com + + * slime.el (slime-show-xrefs): Improved the xrefs buffer, now + using a custom minor mode. + (slime-next-location): This function goes to the next "something" + by funcall'ing slime-next-location-function. Currently that + variable is set by xref commands like who-calls to go to the next + matching reference. In future it can also be used to go to the + next function definition for a generic-function-understanding + version of edit-fdefinition. Bound to C-M-. and C-c C-SPC, until + we see which binding is better. + +2003-09-22 Luke Gorrie luke@bluetail.com + + * slime.el (slime-symbol-at-point): Now returns a symbol, as the + name suggests. + (slime-symbol-name-at-point): This one returns a string. + (slime-read-symbol): New function for taking the symbol at point, + or prompting if there isn't one. + (slime-edit-fdefinition): Now uses looks up the symbol at point, + not the function being called at point. + + * swank.lisp (who-calls, who-references, who-binds, who-sets, + who-macroexpands): New function. + (present-symbol-before-p): Use `*buffer-package*' when checking + accessibility of symbols. + + * slime.el (slime-restore-window-configuration): New command to + put the Emacs window configuration back the way it was before + SLIME last changed it. + (slime-who-calls, etc): Very basic WHO-{CALLS,..} support. Not + finished, wrestling around trying to make `view-mode' or + `help-mode' help me (I just want to hijack RET and C-m). Bound to + "C-c C-w ...". + +2003-09-21 Luke Gorrie luke@bluetail.com + + * slime.el: Rearranged the `outline-mode' structure slightly. + (slime-check-connected): Using new function to give a helpful + error message if you try to use commands before establishing a + connection to CMUCL. + (sldb-mode): Keys 0-9 are now shortcuts to invoke restarts. + + * README, swank.el: Updated commentary. + +2003-09-20 Luke Gorrie luke@bluetail.com + + * slime.el (slime-choose-overlay-region): Tweaked overlay + placement. + + * swank.lisp (handle-notification): Skipping null + notifications. For some reason CMUCL occasionally calls us with + NIL as each argument. + +2003-09-19 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-connect): Propose default values when called + interactively. + (slime-process-available-input): If possible, use while rather than + recursion. + (slime-compilation-finished-continuation): New function. + (slime-compile-file, slime-compile-defun): Use it. + (slime-forward-source-path): Id an error is encounter move back to the + last valid point. + (slime-eval-region): Use append COND. Send the entire string to the + Lisp side and read&evaluate it there. + (slime-eval-buffer): New function. + (sldb-sugar-move, sldb-details-up, sldb-details-down): New functions. + + * swank.lisp (interactive-eval-region): New function. + (re-evaluate-defvar): New function. + (compile-defun): Install handler for compiler-errors. + (function-first-code-location): Simplified. + +2003-09-17 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-apropos-all): New command, bound to C-c M-a. + (slime-eval): Simplified. + (swank:arglist-string): Send a string and not a symbol. It easier + to package related thins in CL. + (slime-edit-symbol-fdefinition): Prompt when called with + prefix-argument. + (slime-eval-region): New function. + (slime-load-file): New function. + (slime-show-description): Set slime minor mode in Help buffer. + + * swank.lisp: (read-string, from-string): Renamed read-string to + from-string. + (to-string) New function. + (arglist-string): Catch reader errors. + (sldb-loop): Also bind *readstrable*. + + +2003-09-16 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el (slime-toggle-trace-fdefinition): New command. + (slime-symbol-at-point, slime-sexp-at-point): New utility functions. + (slime-edit-symbol-fdefinition): Similar to slime-edit-fdefinition but + uses swank:function-source-location-for-emacs. + (slime-goto-source-location): New function. + (sldb-show-source): Use it. + (slime-read-package-name): Completing read for package names. + (slime-apropos): Use it. + + * swank.lisp (function-source-location, + function-source-location-for-emacs): New functions to extract + source locations from compiled code. For struct-accessors we try + to find the source location of the corresponding constructor. + (list-all-package-names): New function. + (toggle-trace-fdefinition, tracedp): New functions. + +2003-09-15 Helmut Eller e9626484@stud3.tuwien.ac.at + + * slime.el: Moved many CL fragments from slime.el to swank.lisp. + (slime-compile-file, slime-compile-defun, slime-goto-location): + Compiler notes are now represented with a property list. To find + the source expression first move to the file offset of the + top-level form and then use the source path to find the + expression. This should avoid many reader issues. For + compile-defun store the start position of the top-level expression + from the buffer in the compiler notes and use that to locate error + messages. Add error overlays for notes without context to the + first available expression. + + * swank.lisp: Moved many CL fragments from slime.el to swank.lisp. + (defslimefun): New macro. + +2003-09-15 Luke Gorrie luke@bluetail.com + + * slime.el (slime-setup-command-hooks): Removed post-command-hook + that was used for cleaning up input that was unprocessed due to an + error breaking out of the process filter. This is now handled by + an `unwind-protect' in the filter. + + * swank.lisp (apropos-list-for-emacs): Hacked the apropos listing + to accept more options and to specially sort results. + + * slime.el (slime-net-send): Added newlines to messages over the + wire. This makes the protocol nicely readable in Ethereal. + (slime-sync): New function for blocking until asynchronous + requests are complete. + (slime-apropos): Hacked the apropos command: by default, only + external symbols are shown. With a prefix argument you have the + option to include internal symbols and to specify a package. + (slime-run-tests): Extended the test suite. Use `M-x + slime-run-tests' to run it. + +2003-09-14 Luke Gorrie luke@bluetail.com + + * slime.el, swank.lisp: Added the debugger written by Helmut. + + * cmucl-wire.el: Removed. The WIRE communication protocol has been + replaced by a simple custom TCP protocol based on READ/PRIN1 to + send sexps as ascii text. This simplifies the code, makes the + protocol nicely debugable with ethereal, and should ease porting + to other Lisps. Incremented TCP port number to 4005 in honor of + the new protocol. + + In addition, Lisp now always uses *print-case* of :DOWNCASE when + preparing sexps for Emacs. This is in reaction to a bug with Emacs + reading the empty list as `NIL' instead of `nil'. + + * slime.el (slime-net-connect): The Emacs end of the new + communication protocol. + + * swank.lisp (create-swank-server): The Lisp end of the new + communication protocol. + +2003-09-11 Luke Gorrie luke@bluetail.com + + * slime.el (slime-mode): Added Helmut's commands to the mode + description. + (slime-show-apropos): Setting `truncate-lines' to t in apropos + listings, to avoid line-wrapping on overly long descriptions. + (slime-run-tests): Added the beginnings of an automated test + suite. (This is most useful for testing cross-Emacsen + compatibility before releases.) + + * swank.lisp (symbol-external-p): Put back this function which was + lost in a merge. + +2003-09-10 Luke Gorrie luke@bluetail.com + + * slime.el, cmucl-wire.el, swank.lisp: Large patch from Helmut + Eller. Includes: apropos, describe, compile-defun, fully + asynchronous continuation-based wire interface, interactive + evaluation, and more. Very nice :-) + +2003-09-08 Luke Gorrie luke@bluetail.com + + * cmucl-wire.el (wire-symbol-name, wire-symbol-package): Fixed to + handle internal references (pkg::name). + + * slime.el (slime-swank-connection-retries): Increased default + number of connection retries from 5 to ten. + + * swank.lisp (find-fdefinition): Support for finding + function/macro definitions for Emacs. + + * slime.el: Indentation "cleanups": somehow I was using + `common-lisp-indent-function' for Emacs Lisp code previously. + (slime-edit-fdefinition): Added M-. (edit definition) and M-, (pop + definition stack) commands. Definitions are found in much the same + way Hemlock does it. The user-interface is not the same as TAGS, + because I like this one better. We can add TAGS-compatibility as + an optional feature in future. + +2003-09-04 Luke Gorrie luke@bluetail.com + + * slime.el (slime-completions): Now supports completing + package-internal symbols with "pkg::prefix" syntax. + + * Everything: imported slime-0.2 sources. + +;; Local Variables: +;; coding: latin-1 +;; End: + +This file has been placed in the public domain.
Added: branches/trunk-reorg/thirdparty/slime/HACKING =================================================================== --- branches/trunk-reorg/thirdparty/slime/HACKING 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/HACKING 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,136 @@ +* The SLIME Hacker's Handbook -*- outline -*- + +* Lisp code file structure + +The Lisp code is organised into these files: + + swank-backend.lisp: + Definition of the interface to non-portable features. + Stand-alone. + + swank-<cmucl|...>.lisp: + Backend implementation for a specific Common Lisp system. + Uses swank-backend.lisp. + + swank.lisp: + The top-level server program, built from the other components. + Uses swank-backend.lisp as an interface to the actual backends. + +* ChangeLog + +For each change we make an entry in the ChangeLog file. This is +typically done using the command `add-change-log-entry-other-window' +(C-x 4 a). The message can be automatically extracted from the +ChangeLog to use in a CVS commit message by pressing C-c C-a in a +vc-mode or pcl-cvs commit buffer. + +ChangeLog diffs are automatically sent to the slime-devel mailing list +each day as a sort of digest summary of the slime-cvs list. + +There are good tips on writing ChangeLog entries in the GNU Coding Standards: + http://www.gnu.org/prep/standards_40.html#SEC40 + +For information about Emacs's ChangeLog support see the `Change Log' +and `Change Logs and VC' nodes of the Emacs manual: + http://www.gnu.org/software/emacs/manual/html_node/emacs_333.html#SEC333 + http://www.gnu.org/software/emacs/manual/html_node/emacs_156.html#SEC156 + +* Sending Patches + +If you would like to send us improvements you can create a patch with +C-x v = in the buffer or manually with 'cvs diff -u'. It's helpful if +you also include a ChangeLog entry describing your change. + +* Test Suite + +The Elisp code includes a command `slime-run-tests' to run a test +suite. This can give a pretty good sanity-check for your changes. + +Some backends do not pass the full test suite because of missing +features. In these cases the test suite is still useful to ensure that +changes don't introduce new errors. CMUCL historically passes the full +test suite so it makes a good sanity check for fundamental changes +(e.g. to the protocol). + +Running the test suite, adding new cases, and increasing the number of +cases that backends support are all very good for karma. + + +* Source code layout + +We use a special source file layout to take advantage of some fancy +Emacs features: outline-mode and "narrowing". + +** Outline structure + +Our source files have a hierarchical structure using comments like +these: + + ;;;; Heading + ;;;;; Subheading + ... etc + +We do this as a nice way to structure the program. We try to keep each +(sub)section small enough to fit in your head: typically around 50-200 +lines of code each. Each section usually begins with a brief +introduction, followed by its highest-level functions, followed by +their subroutines. This is a pleasing shape for a source file to have. + +Of course the comments mean something to Emacs too. One handy usage is +to bring up a hyperlinked "table of contents" for the source file +using this command: + + (defun show-outline-structure () + "Show the outline-mode structure of the current buffer." + (interactive) + (occur (concat "^" outline-regexp))) + +Another is to use `outline-minor-mode' to fold away certain parts of +the buffer. See the `Outline Mode' section of the Emacs manual for +details about that. + +(This file is also formatted for outline mode. If you're reading in +Emacs you can play around e.g. by pressing `C-c C-d' right now.) + +** Pagebreak characters (^L) + +We partition source files into chunks using pagebreak characters. Each +chunk is a substantial piece of code that can be considered in +isolation, that could perhaps be a separate source file if we were +fanatical about small source files (rather than big ones!) + +The page breaks usually go in the same place as top-level outline-mode +headings, but they don't have to. They're flexible. + +In the old days, when slime.el was less than 100 pages long, these +page breaks were helpful when printing it out to read. Now they're +useful for something else: narrowing. + +You can use `C-x n p' (narrow-to-page) to "zoom in" on a +pagebreak-delimited section of the file as if it were a separate +buffer in itself. You can then use `C-x n w' (widen) to "zoom out" and +see the whole file again. This is tremendously helpful for focusing +your attention on one part of the program as if it were its own file. + +(This file contains some page break characters. If you're reading in +Emacs you can press `C-x n p' to narrow to this page, and then later +`C-x n w' to make the whole buffer visible again.) + + +* Coding style + +We like the fact that each function in SLIME will fit on a single +screen (80x20), and would like to preserve this property! Beyond that +we're not dogmatic :-) + +In early discussions we all made happy noises about the advice in +Norvig and Pitman's _Tutorial on Good Lisp Programming Style_: + http://www.norvig.com/luv-slides.ps + +For Emacs Lisp, we try to follow the _Tips and Conventions_ in +Appendix D of the GNU Emacs Lisp Reference Manual (see Info file +`elisp', node `Tips'). + +Remember that to rewrite a program better is the sincerest form of +code appreciation. When you can see a way to rewrite a part of SLIME +better, please do so!
Added: branches/trunk-reorg/thirdparty/slime/NEWS =================================================================== --- branches/trunk-reorg/thirdparty/slime/NEWS 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/NEWS 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,110 @@ +* SLIME News -*- outline -*- + +* 1.2 (March 2005) + +** New inspector +The lisp side now returns a specially formated list of "things" to +format which are then passed to emacs and rendered in the inspector +buffer. Things can be either text, recursivly inspectable values, or +functions to call. The new inspector has much better support CLOS +objects and methods. + +** Unicode +It's now possible to send non-ascii characters to Emacs, if the +communication channel is configured properly. See the variable +`slime-net-coding-system'. + +** Arglist lookup while debugging +Previously, arglist lookup was disabled while debugging. This +restriction was removed. + +** Extended tracing command +It's now possible to trace individual a single methods or all methods +of a generic function. Also tracing can be restricted to situations +in which the traced function is called from a specific function. + +** M-x slime-browse-classes +A simple class browser was added. + +** FASL files +The fasl files for different Lisp/OS/hardware combinations are now +placed in different directories. + +** Many other small improvements and bugfixes + +* 1.0 (September 2004) + +** slime-interrupt +The default key binding for slime-interrupt is now C-c C-b. + +** sldb-inspect-condition +In SLDB 'C' is now bound to sldb-inspect-condition. + +** More Menus +SLDB and the REPL have now pull-down menus. + +** Global debugger hook. +A new configurable *global-debugger* to control whether +swank-debugger-hook should be installed globally is available. True by +default. + +** When you call sldb-eval-in-frame with a prefix argument, the result is +now inserted in the REPL buffer. + +** Compile function +For Allegro M-. works now for functions compiled with C-c C-c. + +** slime-edit-definition +Better support for Allegro: works now for different type of +definitions not only. So M-. now works for e.g. classes in Allegro. + +** SBCL 0.8.13 +SBCL 0.8.12 is no longer supported. Support for 0.8.12 was broken for +for some time now. + +* 1.0 beta (August 2004) + +** autodoc global variables +The slime-autodoc-mode will now automatically show the value of a +global variable at point. + +** Customize group +The customize group is expanded and better-organised. + +** slime-interactive-eval +Interactive-eval commands now print their results to the REPL when +given a prefix argument. + +** slime-conservative-indentation +New Elisp variable. Non-nil means that we exclude def* and with-* from +indentation-learning. The default is t. + +** (slime-setup) +New function to streamline setup in ~/.emacs + +** Modeline package +The package name in the modeline is now updated on an idle timer. The +message should now be more meaningful when moving around in files +containing multiple IN-PACKAGE forms. + +** XREF bugfix +The XREF commands did not find symbols in the right package. + +** REPL prompt +The package name in the REPL's prompt is now abbreviated to the last +`.'-delimited token, e.g. MY.COMPANY.PACKAGE would be PACKAGE. This +can be disabled by setting SWANK::*AUTO-ABBREVIATE-DOTTED-PACKAGES* to +NIL. + +** CMUCL source cache +The source cache is now populated on `first-change-hook'. This makes +M-. work accurately in more file modification scenarios. + +** SBCL compiler errors +Detect compiler errors and make some noise. Previously certain +problems (e.g. reader-errors) could slip by quietly. + +* 1.0 alpha (June 2004) + +The first preview release of SLIME. +
Added: branches/trunk-reorg/thirdparty/slime/PROBLEMS =================================================================== --- branches/trunk-reorg/thirdparty/slime/PROBLEMS 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/PROBLEMS 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,95 @@ +Known problems with SLIME -*- outline -*- + +* Common to all backends + +** Caution: network security +The `M-x slime' command has Lisp listen on a TCP socket and wait for +Emacs to connect, which typically takes on the order of one second. If +someone else were to connect to this socket then they could use the +SLIME protocol to control the Lisp process. + +The listen socket is bound on the loopback interface in all Lisps that +support this. This way remote hosts are unable to connect. + +** READ-CHAR-NO-HANG is broken + +READ-CHAR-NO-HANG doesn't work properly for slime-input-streams. Due +to the way we request input from Emacs it's not possible to repeatedly +poll for input. To get any input you have to call READ-CHAR (or a +function which calls READ-CHAR). + +* Backend-specific problems + +** CMUCL + +The default communication style :SIGIO is reportedly unreliable with +certain libraries (like libSDL) and certain platforms (like Solaris on +Sparc). It generally works very well on x86 so it remains the default. + +** SBCL + +The latest released version of SBCL at the time of packaging should +work. Older or newer SBCLs may or may not work. Do not use +multithreading with unpatched 2.4 Linux kernels. There are also +problems with kernel versions 2.6.5 - 2.6.10. + +The (v)iew-source command in the debugger can only locate exact source +forms for code compiled at (debug 2) or higher. The default level is +lower and SBCL itself is compiled at a lower setting. Thus only +defun-granularity is available with default policies. + +The XREF commands are not implemented. + +** OpenMCL + +We support OpenMCL 0.14.3. + +The XREF commands are not available. + +** LispWorks + +On Windows, SLIME hangs when calling foreign functions or certain +other functions. The reason for this problem is unknown. + +We only support latin1 encoding. (Unicode wouldn't be hard to add.) + +** Allegro CL + +Interrupting Allegro with C-c C-b can be slow. This is caused by the +a relatively large process-quantum: 2 seconds by default. Allegro +responds much faster if mp:*default-process-quantum* is set to 0.1. + +** CLISP + +We require version 2.33.2 or higher. We also require socket support, so +you may have to start CLISP with "clisp -K full". + +Under Windows, interrupting (with C-c C-b) doesn't work. Emacs sends +a SIGINT signal, but the signal is either ignored or CLISP exits +immediately. + +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.
Added: branches/trunk-reorg/thirdparty/slime/README =================================================================== --- branches/trunk-reorg/thirdparty/slime/README 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/README 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,41 @@ +Overview. +---------------------------------------- + + SLIME is the Superior Lisp Interaction Mode for Emacs. It is + implemented in two main parts: the Emacs Lisp side (slime.el), and + the support library for the Common Lisp (swank.lisp and swank-*.lisp) + + For a real description, see the manual in doc/ + +Quick setup instructions +------------------------ + + Add this to your ~/.emacs file and fill in the appropriate filenames: + + (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) + + Make sure your `inferior-lisp-program' is set to a compatible + version of Lisp. + + Use `M-x' slime to fire up and connect to an inferior Lisp. + SLIME will now automatically be available in your Lisp source + buffers. + +Licence. +---------------------------------------- + + SLIME is free software. All files, unless explicitly stated + otherwise, are public domain. + +Contact. +---------------------------------------- + + Questions and comments are best directed to the mailing list: + http://common-lisp.net/mailman/listinfo/slime-devel + + The mailing list archive is also available on Gmane: + http://news.gmane.org/gmane.lisp.slime.devel +
Added: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,30 @@ +/ChangeLog/1.62/Mon Oct 1 13:37:22 2007// +/README/1.3/Fri Sep 28 13:05:44 2007// +/bridge.el/1.1/Wed Sep 19 11:47:03 2007// +/inferior-slime.el/1.2/Mon Sep 10 21:44:48 2007// +/slime-asdf.el/1.3/Fri Sep 21 12:44:13 2007// +/slime-autodoc.el/1.5/Mon Oct 1 13:37:10 2007// +/slime-banner.el/1.4/Thu Sep 20 14:55:53 2007// +/slime-c-p-c.el/1.8/Thu Sep 20 14:55:53 2007// +/slime-editing-commands.el/1.5/Thu Sep 20 14:55:53 2007// +/slime-fancy-inspector.el/1.2/Thu Sep 20 14:55:53 2007// +/slime-fancy.el/1.4/Fri Sep 28 13:05:35 2007// +/slime-fuzzy.el/1.4/Thu Sep 20 14:55:53 2007// +/slime-highlight-edits.el/1.3/Thu Sep 20 14:55:53 2007// +/slime-parse.el/1.7/Sat Sep 15 11:09:36 2007// +/slime-presentation-streams.el/1.2/Tue Aug 28 08:25:12 2007// +/slime-presentations.el/1.8/Thu Sep 20 14:55:53 2007// +/slime-references.el/1.4/Thu Sep 20 14:55:53 2007// +/slime-scratch.el/1.4/Thu Sep 20 14:55:53 2007// +/slime-tramp.el/1.2/Tue Sep 4 10:18:44 2007// +/slime-typeout-frame.el/1.5/Mon Oct 1 11:50:06 2007// +/slime-xref-browser.el/1.1/Fri Aug 24 14:47:11 2007// +/swank-arglists.lisp/1.10/Tue Sep 11 12:33:00 2007// +/swank-asdf.lisp/1.1/Tue Sep 4 10:32:07 2007// +/swank-c-p-c.lisp/1.2/Wed Sep 5 19:35:35 2007// +/swank-fancy-inspector.lisp/1.4/Thu Sep 20 14:55:53 2007// +/swank-fuzzy.lisp/1.6/Sat Sep 15 22:21:21 2007// +/swank-listener-hooks.lisp/1.1/Tue Aug 28 13:53:02 2007// +/swank-presentation-streams.lisp/1.4/Tue Aug 28 16:26:32 2007// +/swank-presentations.lisp/1.4/Tue Sep 4 09:49:10 2007// +D
Added: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Repository 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Repository 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +slime/contrib
Added: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Root 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Root 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +:pserver:anonymous:anonymous@common-lisp.net:/project/slime/cvsroot
Added: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Template ===================================================================
Added: branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,500 @@ +2007-10-01 Tobias C. Rittweiler tcr@freebits.de + + * slime-autdoc.el (slime-autodoc-message-ok-p): Don't display an + arglist when the minibuffer is active. + +2007-10-01 Tobias C. Rittweiler tcr@freebits.de + + * slime-typeout-frame.el: Messages in the typeout frame were too + easily overwritten by `slime-autodoc'. Fix that. + Reported by Geoff Wozniak. + + (slime-typeout-message-aux): Split out from `slime-typeout-message'. + (slime-typeout-message): Wrapper around it. Additionally disable + the autodoc timer temporarily. + +2007-09-30 Geoff Wozniak geoff@wozniak.ca + + * slime-typeout-frame.el (slime-typeout-frame-init): Fix quoted + FUNCTION forms in literal. + +2007-09-28 Tobias C. Rittweiler tcr@freebits.de + + * README: Updated. + + * slime-fancy.el: `slime-highlighting-edits' is not enabled by + default anymore, as its functionality is controversial, and it's + easier to explicitly enable it than to disable it once it got + globally activated. Better to be conservative. + + * slime-fancy.el: Not only load, but also enable `slime-scratch'. + +2007-09-21 Helmut Eller heller@common-lisp.net + + * slime-asdf.el (slime-asdf-init, slime-asdf-unload): Fix typos. + Reported by Ariel Badichi. + +2007-09-20 Helmut Eller heller@common-lisp.net + + Separate loading from initialization for many contribs. + + * slime-asdf.el + * slime-autodoc.el + * slime-banner.el + * slime-c-p-c.el + * slime-editing-commands.el + * slime-fancy-inspector.el + * slime-fuzzy.el + * slime-highlight-edits.el + * slime-presentations.el + * slime-references.el + * slime-scratch.el + * slime-typeout-frame.el + * swank-fancy-inspector.lisp + + * slime-fancy.el: As an exception, call the respective init + function when loading. + +2007-09-19 Helmut Eller heller@common-lisp.net + + * slime-c-p-c.el (slime-complete-symbol*-fancy): Move defcustom + from slime.el to contrib/slime-c-p-c.el. + +2007-09-16 Tobias C. Rittweiler tcr@freebits.de + + * swank-fuzzy.lisp: Fix regression that would not allow to fuzzy + complete on inputs without package qualifier like "app". + Reported by David J. Neu. + + (%make-duplicate-symbols-filter): Return complement. + (fuzzy-find-matching-symbols): Treat passed filter as an acceptor + predicate, not as a rejector. + +2007-09-15 Helmut Eller heller@common-lisp.net + + Add the necessary hooks when loading some contribs, so that those + contribs can be easily loaded with slime-setup. + + * slime-highlight-edits.el (slime-highlight-edits-mode-on): New + function. Add this to slime-mode-hook by default. + + * slime-autodoc.el (slime-use-autodoc-mode): Change default to t. + +2007-09-15 Ariel Badichi abadichi@bezeqint.net + + * swank-fancy-inspector.lisp (inspect-for-emacs package): When + inspecting a package, the links in the use list and the used-by + list lead to inspecting package names, rather than the packages + themselves. Fix that. + +2007-09-15 Tobias C. Rittweiler tcr@freebits.de + + * slime-parse.el: Fix extended arglist display on misbalanced + expressions like `(defun foo | ... (defun bar () 'bar)' + Reported by Ariel Badichi. + + (slime-inside-string-p): Use `beginning-of-defun' directly than + relying on `slime-region-for-defun-at-point' (as this one uses + `end-of-defun' which signals an error on misbalanced expressions.) + +2007-09-15 Tobias C. Rittweiler tcr@freebits.de + + * swank-fuzzy.lisp: Code reorganization and cleanup; making it + compute less and couple of other minor issues fixed on the + way. Thanks to Stelian Ionescu for testing and providing feedback! + + (defstruct fuzzy-matching): New `package-name' slot. + (make-fuzzy-matching): Updated for new slot. + (format-completion-result): Renamed to `fuzzy-format-matching'. + (%fuzzy-extract-matching-info): Helper for `fuzzy-format-matching'. + + (fuzzy-completion-set): Convert the matchings after they got + truncated to the passed completion-set limit from Emacs. + I.e. `slime-fuzzy-completion-limit' This means a huge + computational reduction. + + (fuzzy-create-completion-set): Renamed to `fuzzy-generate-matchings'. + (fuzzy-generate-matchings): Returns the fuzzy matchings + themselves, do not yet convert them for Emacs. Do not perform two + sorts on the generated matchings (first alphabetically, then per + score), but just one with an appropriate predicate that sorts per + score, unless matchings are equal, then sort alphabetically. Prune + matchings with symbols which are found in a differenta package + than their home package when the home package is among the matched + packages. Try to take the time needed to sort the generated + matchings into account for the time-limit. + (%guess-sort-duration): Helper. + Tries to guess how long the sort will take. + (%make-duplicate-symbols-filter): Helper. + Used for pruning of matchings. + (fuzzy-matching-greaterp): New testing predicate for sorting. + + (fuzzy-find-matching-symbols): Now takes a :filter keyarg; only + considers symbols that pass through the filter. + (fuzzy-find-matching-packages): Do not return matchings for all + nicknames of package, but just the one that matches best. + +2007-09-11 Tobias C. Rittweiler tcr@freebits.de + + * slime-editing-commands.el: Automatically bind the editing + commands when this module is required. (Previously, one had to + enable them explicitly, but this is inconsistent to, for instance, + the `slime-c-p-c' module which also sets up its bindings + automatically.) + (slime-bind-editing-commands): Renamed to `slime-editing-commands-init'. + (slime-editing-commands-init): Evaluated at toplevel. + +2007-09-11 Tobias C. Rittweiler tcr@freebits.de + + * slime-parse.el (slime-enclosing-form-specs): Now also works even + when point is inside a string. + (slime-inside-string-p): New function. + (slime-beginning-of-string): New function. + +2007-09-11 Tobias C. Rittweiler tcr@freebits.de + + * swank-arglist.lisp (read-conversatively-for-autodoc): Also parse + quoted symbols explicitly. This fixed extended arglist display for + `(make-instance 'foo'. Reported by: Johannes Groedem. + +2007-09-11 Tobias C. Rittweiler tcr@freebits.de + + * slime-fancy.el: Require `slime-references'. + +2007-09-10 Helmut Eller heller@common-lisp.net + + * slime-parse.el (slime-cl-symbol-name, slime-cl-symbol-package): + Move from slime.el to contrib/slime-parse.el. + +2007-09-10 Helmut Eller heller@common-lisp.net + + * inferior-slime.el: Fix installation comment. + +2007-09-10 Helmut Eller heller@common-lisp.net + + Fix some of the bugs introduced with the last change. + + * slime-references.el (sldb-reference-face): Add missing quote. + (sldb-reference-properties): We are lucky and can use keywords + instead of strings. + (sldb-maybe-insert-references): Insert newlines differently. + +2007-09-10 Helmut Eller heller@common-lisp.net + + Move SBCL doc references to contrib. + + * slime-references.el: New file. + +2007-09-10 Attila Lendvai attila.lendvai@gmail.com + + * slime-fuzzy.el: Fixed some race condition that prevented a + proper closing of the *Fuzzy Completions* buffer in some + circumstances. + + (slime-fuzzy-save-window-configuration): Removed. Hooking up + `window-configuration-change-hook' via `run-with-timer' was racy + and lead to this bug; we now set the hook explicitely at the + necessary place instead. + (slime-fuzzy-window-configuration-change-add-hook): Removed. + (slime-fuzzy-choices-buffer): Explicitly save the + window-configuration, and explicitly set the hook. + (slime-fuzzy-done): Explicitely remove the hook. + +2007-09-10 Tobias C. Rittweiler tcr@freebits.de + + * slime-parse.el (slime-cl-symbol-name, slime-cl-symbol-package): + Moved back into slime.el. + +2007-09-08 Stelian Ionescu sionescu@common-lisp.net + + * slime-banner.el: Fixed typo to provide `slime-banner', not + `slime-startup-animation'. + +2007-09-06 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime-presentations.el (slime-presentation-write): Use case, not + ecase, for dispatching targets. Should fix XEmacs compatibility. + Reported by Steven E. Harris. + +2007-09-05 Tobias C. Rittweiler tcr@freebits.de + + * swank-c-p-c.el: This file incorrectly provided the module + `:swank-compound-prefix'; changed that to `:swank-c-p-c'. + + This gets rid off the nasty redefinition warnings that were + previously signalled when loading SWANK with SBCL. + + * swank-arglist.lisp (arglist-for-echo-area): Locally declare + `*arglist-pprint-bindings*' to be special, as the variable is + defined later in the file. (Gets rid of warnings during loading.) + +2007-09-05 Tobias C. Rittweiler tcr@freebits.de + + * slime-c-p-c.el (slime-c-p-c-init): Bind `slime-complete-form' to + `C-c C-s' in `slime-repl-mode-map'. + +2007-09-05 Tobias C. Rittweiler tcr@freebits.de + + Added extended arglist display for DECLAIM and PROCLAIM. + + * slime-parse.el (slime-extended-operator-name-parser-alist): Added + entries for "DECLAIM", and "PROCLAIM". + (slime-parse-extended-operator/declare): Provide information about + the operator the arglist is requested for. + (slime-make-form-spec-from-string): Fixed for "()" as input. + + * swank-arglists.lisp (valid-operator-symbol-p): Explicitly allow + the symbol 'DECLARE. + (arglist-dispatch): New method for `DECLARE'. We have to catch + this explicitly, as DECLARE doesn't have an arglist (in the + `swank-backend:arglist' sense.) + (*arglist-pprint-bindings*): New variable. Splitted out from + `decoded-arglist-to-string'. + (decoded-arglist-to-string): Use `*arglist-pprint-bindings*'. + + (parse-first-valid-form-spec): Rewritten, because function + signature had to be changed: doesn't take arg-indices anymore; + returns position of first valid spec as second value to remedy. + (arglist-for-echo-area): Accomodated to new signature of + `parse-first-valid-form-spec'; now searchs for contextual + declaration operator name, to prefix a declaration arglist by + "declare", "declaim", or "proclaim" depending on what was used at + user's point in Slime. Use `*arglist-pprint-bindings*' for + printing the found declaration operator name. + (%find-declaration-operator): New helper to do this search. + (completions-for-keyword): Accomodated to new signature of + `parse-first-valid-form-spec'. Also fixed to correctly provide + keyword completions in nested expressions like: + + `(defun foo (x) + (let ((bar 'quux)) + (with-open-file (s f :|' [`|' being point] + +2007-09-04 Helmut Eller heller@common-lisp.net + + * swank-arglists.lisp (parse-first-valid-form-spec): Rewrite it for + ABCL. + +2007-09-04 Helmut Eller heller@common-lisp.net + + Some bug fixes for slime-complete-symbol*. + Patches by Mr. Madhu enometh@meer.net + + * slime-c-p-c.el (slime-c-p-c-unambiguous-prefix-p): New variable. + (slime-expand-abbreviations-and-complete): Use it. Also add a + workaround for XEmacs issues. + +2007-09-04 Helmut Eller heller@common-lisp.net + + Move asdf support to contrib: + + * slime-asdf.el: New file. + + * swank-asdf.lisp: New file + (operate-on-system, asdf-central-registry) + (list-all-systems-known-to-asdf): Use the asdf package in the + source code, i.e. write asdf:operate instead of + (find-symbol "OPERATE" "ASDF"). + +2007-09-04 Helmut Eller heller@common-lisp.net + + * slime-tramp.el: New file. + * slime-banner.el: New file. + * inferior-slime.el: New file. + +2007-09-01 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime-fancy.el: New meta-contrib. + +2007-09-01 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime-presentations.el (slime-dispatch-presentation-event): + Explicitly return t to indicate the events have been handled, + rather than relying on the return values of the called functions. + +2007-09-01 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime-typeout-frame.el (slime-typeout-autodoc-message): Fix for + messages that contain "%". Reported by Martin Simmons. + +2007-09-01 Tobias C. Rittweiler tcr@freebits.de + + Makes `slime-complete-form' work on `(eval-when |'; doesn't work + on `(eval-when (|' yet. + + * slime-parse.el (slime-parse-sexp-at-point): Guard against + `(char-after)' being NIL at end of buffer (especially important + for use on the REPL.) + + * swank-arglist.lisp (arglist-dispatch 'eval-when): Fix typo. + (print-decoded-arglist-as-template): Print keywords with PRIN1. + +2007-08-31 Tobias C. Rittweiler tcr@freebits.de + + Added extended arglist display for EVAL-WHEN, viz: + + (eval-when (&any :compile-toplevel :load-toplevel :execute) &body body) + + Notice that completion works as expected on these keywords. + + Die, EVAL-ALWAYS, die! + + * swank-arglist (arglist-dispatch): New method for EVAL-WHEN. + (print-arglist): Print keywords with PRIN1 rather than PRINC, + to get a result as shown above for the EVAL-WHEN case. + (completions-for-keyword): Add support for &ANY args. + +2007-08-31 Tobias C. Rittweiler tcr@freebits.de + + * swank-arglist.lisp: Do not fall back to READ when interpreting + the ``raw form specs'' comming from Slime's autodoc stuff. But + still do so for those comming from `slime-complete-form'. + + (unintern-in-home-package): New. + + (*arglist-dummy*): New. + (read-conversatively-for-autodoc): New function. Doesn't READ + anything that comes from Slime's autodoc. Just tries to parse + symbols. If that's not successfull, returns the dummy placeholder + datum stored in `*arglist-dummy*'. + (arglist-for-echo-area): Parse form-specs using + `read-conversatively-for-autodoc'. Use `unintern-in-home-package'. + + (read-softly): New. Splitted out from `read-form-spec'. This + function tries to keep track of newly interned functions before + READing. + (read-form-spec): Parametrized to take a function to read the + elements of the passed ``raw form spec''. Uses `read-softly' as + default reader. + + (complete-form, completions-for-keywords): + Use `unintern-in-home-package'. + +2007-08-31 Helmut Eller heller@common-lisp.net + + * slime-autodoc.el: Add installation notes. + * slime-editing-commands.el: Add installation notes. + * slime-c-p-c.el (slime-c-p-c-init): Fix typos. + +2007-08-31 Helmut Eller heller@common-lisp.net + + Move compound prefix completion and autodoc to contrib. + Interdependencies made it almost necessary to move parsing code + and editing commands in the same patch. + + * slime-c-p-c.el: New file. + * swank-c-p-c.el: New file. + * slime-parse.el: New file. + * swank-arglists.el: New file. + * slime-editing-commands.el: New file. + * slime-autodoc.el: New file. + +2007-08-28 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * slime-presentations.el (slime-last-output-target-id) + (slime-output-target-to-marker, slime-output-target-marker) + (slime-redirect-trace-output): Moved back into SLIME core. + + * swank-presentation-streams.lisp: Require swank-presentations. + (present-repl-results-via-presentation-streams): New. + (*send-repl-results-function*): Set this variable rather than + overriding send-repl-results-to-emacs. + +2007-08-28 Helmut Eller heller@common-lisp.net + + * slime-presentations.el (slime-clear-presentations): New + function. Add it to slime-repl-clear-buffer-hook. + +2007-08-28 Helmut Eller heller@common-lisp.net + + * swank-listener-hooks.lisp: New file + +2007-08-28 Helmut Eller heller@common-lisp.net + + Move the rest of the presentation related code. + + * swank-presentations.lisp (present-repl-results): Renamed from + send-repl-results-to-emacs. + +2007-08-28 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + * swank-presentations.lisp (send-repl-results-to-emacs): + Override core defun to mark up REPL results as presentations. + + * swank-presentations.lisp: New file. + * slime-presentations.el: Load it. + + * slime-presentations.el (slime-presentation-write): Remove id + argument. + + * slime-presentation-streams.el: Require slime-presentations contrib. + +2007-08-27 Helmut Eller heller@common-lisp.net + + Move presentations to contrib. (ELisp part) + + * slime-presentations.el: New file. + * slime-scratch.el (slime-scratch-buffer): Ignore presentations. + +2007-08-24 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Some fixes to the presentation-streams contrib. + + * swank-presentation-streams.lisp [sbcl]: Load the pretty-printer + patch only at load time. Add some trickery so that SBCL does not + complain about the changed layout of the pretty-stream class. + + * swank-presentation-streams.lisp (slime-stream-p): Using special + return values, indicate whether we are printing to the + REPL-results stream, or a dedicated stream. + (presentation-record): New slot "target". + (presentation-start, presentation-end): Use it (rather than the + global variable *use-dedicated-output-stream*) to decide whether + to use the bridge protocol or the :presentation-start/-end + protocol. Also use it as the TARGET argument of + :presentation-start/-end messages. + (presenting-object-1): Use the new return values of + slime-stream-p. + + * swank-presentation-streams.lisp (slime-stream-p) [cmu]: Use the + return value of slime-stream-p rather than the global variable + *use-dedicated-output-stream* to decide whether printing through + pretty streams is safe for the layout. + +2007-08-24 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de + + Make the fancy "presentation streams" feature a contrib. + Previously, it was only available if "present.lisp" was loaded + manually. + + * slime-presentation-streams.el: New file. + * swank-presentation-streams.lisp: New file, moved here from + ../present.lisp + +2007-08-24 Helmut Eller heller@common-lisp.net + + * slime-typeout-frame.el: New file. + * slime-xref-browser.el: New file. + * slime-highlight-edits.el: New file. + * slime-scratch.el: New file. + +2007-08-23 Helmut Eller heller@common-lisp.net + + Move Marco Baringer's inspector to contrib. + + * swank-fancy-inspector.lisp: New file. The only difference to the + code is that inspect-for-emacs methods in this file are + specialized to the new class `fancy-inspector'. + (fancy-inspector): New class. + + * slime-fancy-inspector.el: New file. + +2007-08-19 Helmut Eller heller@common-lisp.net + + Moved fuzzy completion code to contrib directory. + + * slime-fuzzy.el: New file. + (slime-fuzzy-init): New function. Load CL code on startup. + + * swank-fuzzy.lisp: New file. Common Lisp code for fuzzy + completion.
Added: branches/trunk-reorg/thirdparty/slime/contrib/README =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/README 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/README 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,30 @@ +This directory contains source code which may be useful to some Slime +users. *.el files are Emacs Lisp source and *.lisp files contain +Common Lisp source code. If not otherwise stated in the file itself, +the files are placed in the Public Domain. + +The components in this directory are more or less detached from the +rest of Slime. They are essentially "add-ons". But Slime can also be +used without them. The code is maintained by the respective authors. + +To use the packages here, you should add this directory to your Emacs +load-path, require the contrib, and call the contrib's init function to +enable the functionality that's provided by the respective contrib. + +E.g. for fuzzy completion add this to your .emacs: + + (add-to-list 'load-path "<this-directory>") + (add-hook 'slime-load-hook (lambda () (require 'slime-fuzzy) + (slime-fuzzy-init))) + +Alternatively, you can use the `slime-setup' function which takes a +list of contrib names, and which loads and enables them automatically +for you: + + (slime-setup '(slime-fancy slime-asdf slime-tramp ...)) + + +Finally, the contrib `slime-fancy' is specially noteworthy, as it +represents a meta-contrib that'll load a bunch of commonly used +contribs. Look into `slime-fancy.el' to find out which. + \ No newline at end of file
Added: branches/trunk-reorg/thirdparty/slime/contrib/bridge.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/bridge.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/bridge.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,467 @@ +;;; -*-Emacs-Lisp-*- +;;;%Header +;;; Bridge process filter, V1.0 +;;; Copyright (C) 1991 Chris McConnell, ccm@cs.cmu.edu +;;; +;;; Send mail to ilisp@cons.org if you have problems. +;;; +;;; Send mail to majordomo@cons.org if you want to be on the +;;; ilisp mailing list. + +;;; This file is part of GNU Emacs. + +;;; GNU Emacs is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY. No author or distributor +;;; accepts responsibility to anyone for the consequences of using it +;;; or for whether it serves any particular purpose or works at all, +;;; unless he says so in writing. Refer to the GNU Emacs General Public +;;; License for full details. + +;;; Everyone is granted permission to copy, modify and redistribute +;;; GNU Emacs, but only under the conditions described in the +;;; GNU Emacs General Public License. A copy of this license is +;;; supposed to have been given to you along with GNU Emacs so you +;;; can know your rights and responsibilities. It should be in a +;;; file named COPYING. Among other things, the copyright notice +;;; and this notice must be preserved on all copies. + +;;; Send any bugs or comments. Thanks to Todd Kaufmann for rewriting +;;; the process filter for continuous handlers. + +;;; USAGE: M-x install-bridge will add a process output filter to the +;;; current buffer. Any output that the process does between +;;; bridge-start-regexp and bridge-end-regexp will be bundled up and +;;; passed to the first handler on bridge-handlers that matches the +;;; output using string-match. If bridge-prompt-regexp shows up +;;; before bridge-end-regexp, the bridge will be cancelled. If no +;;; handler matches the output, the first symbol in the output is +;;; assumed to be a buffer name and the rest of the output will be +;;; sent to that buffer's process. This can be used to communicate +;;; between processes or to set up two way interactions between Emacs +;;; and an inferior process. + +;;; You can write handlers that process the output in special ways. +;;; See bridge-send-handler for the default handler. The command +;;; hand-bridge is useful for testing. Keep in mind that all +;;; variables are buffer local. + +;;; YOUR .EMACS FILE: +;;; +;;; ;;; Set up load path to include bridge +;;; (setq load-path (cons "/bridge-directory/" load-path)) +;;; (autoload 'install-bridge "bridge" "Install a process bridge." t) +;;; (setq bridge-hook +;;; '(lambda () +;;; ;; Example options +;;; (setq bridge-source-insert nil) ;Don't insert in source buffer +;;; (setq bridge-destination-insert nil) ;Don't insert in dest buffer +;;; ;; Handle copy-it messages yourself +;;; (setq bridge-handlers +;;; '(("copy-it" . my-copy-handler))))) + +;;; EXAMPLE: +;;; # This pipes stdin to the named buffer in a Unix shell +;;; alias devgnu '(echo -n "!* "; cat -; echo -n " ")' +;;; +;;; ls | devgnu *scratch* + +(eval-when-compile + (require 'cl)) + +;;;%Parameters +(defvar bridge-hook nil + "Hook called when a bridge is installed by install-hook.") + +(defvar bridge-start-regexp "" + "*Regular expression to match the start of a process bridge in +process output. It should be followed by a buffer name, the data to +be sent and a bridge-end-regexp.") + +(defvar bridge-end-regexp " " + "*Regular expression to match the end of a process bridge in process +output.") + +(defvar bridge-prompt-regexp nil + "*Regular expression for detecting a prompt. If there is a +comint-prompt-regexp, it will be initialized to that. A prompt before +a bridge-end-regexp will stop the process bridge.") + +(defvar bridge-handlers nil + "Alist of (regexp . handler) for handling process output delimited +by bridge-start-regexp and bridge-end-regexp. The first entry on the +list whose regexp matches the output will be called on the process and +the delimited output.") + +(defvar bridge-source-insert t + "*T to insert bridge input in the source buffer minus delimiters.") + +(defvar bridge-destination-insert t + "*T for bridge-send-handler to insert bridge input into the +destination buffer minus delimiters.") + +(defvar bridge-chunk-size 512 + "*Long inputs send to comint processes are broken up into chunks of +this size. If your process is choking on big inputs, try lowering the +value.") + +;;;%Internal variables +(defvar bridge-old-filter nil + "Old filter for a bridged process buffer.") + +(defvar bridge-string nil + "The current output in the process bridge.") + +(defvar bridge-in-progress nil + "The current handler function, if any, that bridge passes strings on to, +or nil if none.") + +(defvar bridge-leftovers nil + "Because of chunking you might get an incomplete bridge signal - start but the end is in the next packet. Save the overhanging text here.") + +(defvar bridge-send-to-buffer nil + "The buffer that the default bridge-handler (bridge-send-handler) is +currently sending to, or nil if it hasn't started yet. Your handler +function can use this variable also.") + +(defvar bridge-last-failure () + "Last thing that broke the bridge handler. First item is function call +(eval'able); last item is error condition which resulted. This is provided +to help handler-writers in their debugging.") + +;;;%Utilities +(defun bridge-insert (output) + "Insert process OUTPUT into the current buffer." + (if output + (let* ((buffer (current-buffer)) + (process (get-buffer-process buffer)) + (mark (process-mark process)) + (window (selected-window)) + (at-end nil)) + (if (eq (window-buffer window) buffer) + (setq at-end (= (point) mark)) + (setq window (get-buffer-window buffer))) + (save-excursion + (goto-char mark) + (insert output) + (set-marker mark (point))) + (if window + (progn + (if at-end (goto-char mark)) + (if (not (pos-visible-in-window-p (point) window)) + (let ((original (selected-window))) + (save-excursion + (select-window window) + (recenter '(center)) + (select-window original))))))))) + +;;; +;(defun bridge-send-string (process string) +; "Send PROCESS the contents of STRING as input. +;This is equivalent to process-send-string, except that long input strings +;are broken up into chunks of size comint-input-chunk-size. Processes +;are given a chance to output between chunks. This can help prevent processes +;from hanging when you send them long inputs on some OS's." +; (let* ((len (length string)) +; (i (min len bridge-chunk-size))) +; (process-send-string process (substring string 0 i)) +; (while (< i len) +; (let ((next-i (+ i bridge-chunk-size))) +; (accept-process-output) +; (process-send-string process (substring string i (min len next-i))) +; (setq i next-i))))) + +;;; +(defun bridge-call-handler (handler proc string) + "Funcall HANDLER on PROC, STRING carefully. Error is caught if happens, +and user is signaled. State is put in bridge-last-failure. Returns t if +handler executed without error." + (let ((inhibit-quit nil) + (failed nil)) + (condition-case err + (funcall handler proc string) + (error + (ding) + (setq failed t) + (message "bridge-handler "%s" failed %s (see bridge-last-failure)" + handler err) + (setq bridge-last-failure + (` ((funcall '(, handler) '(, proc) (, string)) + "Caused: " + (, err)))))) + (not failed))) + +;;;%Handlers +(defun bridge-send-handler (process input) + "Send PROCESS INPUT to the buffer name found at the start of the +input. The input after the buffer name is sent to the buffer's +process if it has one. If bridge-destination-insert is T, the input +will be inserted into the buffer. If it does not have a process, it +will be inserted at the end of the buffer." + (if (null input) + (setq bridge-send-to-buffer nil) ; end of bridge + (let (buffer-and-start buffer-name dest to) + ;; if this is first time, get the buffer out of the first line + (cond ((not bridge-send-to-buffer) + (setq buffer-and-start (read-from-string input) + buffer-name (format "%s" (car (read-from-string input))) + dest (get-buffer buffer-name) + to (get-buffer-process dest) + input (substring input (cdr buffer-and-start))) + (setq bridge-send-to-buffer dest)) + (t + (setq buffer-name bridge-send-to-buffer + dest (get-buffer buffer-name) + to (get-buffer-process dest) + ))) + (if dest + (let ((buffer (current-buffer))) + (if bridge-destination-insert + (unwind-protect + (progn + (set-buffer dest) + (if to + (bridge-insert process input) + (goto-char (point-max)) + (insert input))) + (set-buffer buffer))) + (if to + ;; (bridge-send-string to input) + (process-send-string to input) + )) + (error "%s is not a buffer" buffer-name))))) + +;;;%Filter +(defun bridge-filter (process output) + "Given PROCESS and some OUTPUT, check for the presence of +bridge-start-regexp. Everything prior to this will be passed to the +normal filter function or inserted in the buffer if it is nil. The +output up to bridge-end-regexp will be sent to the first handler on +bridge-handlers that matches the string. If no handlers match, the +input will be sent to bridge-send-handler. If bridge-prompt-regexp is +encountered before the bridge-end-regexp, the bridge will be cancelled." + (let ((inhibit-quit t) + (match-data (match-data)) + (buffer (current-buffer)) + (process-buffer (process-buffer process)) + (case-fold-search t) + (start 0) (end 0) + function + b-start b-start-end b-end) + (set-buffer process-buffer) ;; access locals + + ;; Handle bridge messages that straddle a packet by prepending + ;; them to this packet. + + (when bridge-leftovers + (setq output (concat bridge-leftovers output)) + (setq bridge-leftovers nil)) + + (setq function bridge-in-progress) + + ;; How it works: + ;; + ;; start, end delimit the part of string we are interested in; + ;; initially both 0; after an iteration we move them to next string. + + ;; b-start, b-end delimit part of string to bridge (possibly whole string); + ;; this will be string between corresponding regexps. + + ;; There are two main cases when we come into loop: + + ;; bridge in progress + ;;0 setq b-start = start + ;;1 setq b-end (or end-pattern end) + ;;4 process string + ;;5 remove handler if end found + + ;; no bridge in progress + ;;0 setq b-start if see start-pattern + ;;1 setq b-end if bstart to (or end-pattern end) + ;;2 send (substring start b-start) to normal place + ;;3 find handler (in b-start, b-end) if not set + ;;4 process string + ;;5 remove handler if end found + + ;; equivalent sections have the same numbers here; + ;; we fold them together in this code. + + (block bridge-filter + (unwind-protect + (while (< end (length output)) + + ;;0 setq b-start if find + (setq b-start + (cond (bridge-in-progress + (setq b-start-end start) + start) + ((string-match bridge-start-regexp output start) + (setq b-start-end (match-end 0)) + (match-beginning 0)) + (t nil))) + ;;1 setq b-end + (setq b-end + (if b-start + (let ((end-seen (string-match bridge-end-regexp + output b-start-end))) + (if end-seen (setq end (match-end 0))) + + end-seen))) + + ;; Detect and save partial bridge messages + (when (and b-start b-start-end (not b-end)) + (setq bridge-leftovers (substring output b-start)) + ) + + (if (and b-start (not b-end)) + (setq end b-start) + (if (not b-end) + (setq end (length output)))) + + ;;1.5 - if see prompt before end, remove current + (if (and b-start b-end) + (let ((prompt (string-match bridge-prompt-regexp + output b-start-end))) + (if (and prompt (<= (match-end 0) b-end)) + (setq b-start nil ; b-start-end start + b-end start + end (match-end 0) + bridge-in-progress nil + )))) + + ;;2 send (substring start b-start) to old filter, if any + (when (not (equal start (or b-start end))) ; don't bother on empty string + (let ((pass-on (substring output start (or b-start end)))) + (if bridge-old-filter + (let ((old bridge-old-filter)) + (store-match-data match-data) + (funcall old process pass-on) + ;; if filter changed, re-install ourselves + (let ((new (process-filter process))) + (if (not (eq new 'bridge-filter)) + (progn (setq bridge-old-filter new) + (set-process-filter process 'bridge-filter))))) + (set-buffer process-buffer) + (bridge-insert pass-on)))) + + (if (and b-start-end (not b-end)) + (return-from bridge-filter t) ; when last bit has prematurely ending message, exit early. + (progn + ;;3 find handler (in b-start, b-end) if none current + (if (and b-start (not bridge-in-progress)) + (let ((handlers bridge-handlers)) + (while (and handlers (not function)) + (let* ((handler (car handlers)) + (m (string-match (car handler) output b-start-end))) + (if (and m (< m b-end)) + (setq function (cdr handler)) + (setq handlers (cdr handlers))))) + ;; Set default handler if none + (if (null function) + (setq function 'bridge-send-handler)) + (setq bridge-in-progress function))) + ;;4 process strin + (if function + (let ((ok t)) + (if (/= b-start-end b-end) + (let ((send (substring output b-start-end b-end))) + ;; also, insert the stuff in buffer between + ;; iff bridge-source-insert. + (if bridge-source-insert (bridge-insert send)) + ;; call handler on string + (setq ok (bridge-call-handler function process send)))) + ;;5 remove handler if end found + ;; if function removed then tell it that's all + (if (or (not ok) (/= b-end end)) ;; saw end before end-of-string + (progn + (bridge-call-handler function process nil) + ;; have to remove function too for next time around + (setq function nil + bridge-in-progress nil) + )) + )) + + ;; continue looping, in case there's more string + (setq start end)) + )) + ;; protected forms: restore buffer, match-data + (set-buffer buffer) + (store-match-data match-data) + )))) + + +;;;%Interface +(defun install-bridge () + "Set up a process bridge in the current buffer." + (interactive) + (if (not (get-buffer-process (current-buffer))) + (error "%s does not have a process" (buffer-name (current-buffer))) + (make-local-variable 'bridge-start-regexp) + (make-local-variable 'bridge-end-regexp) + (make-local-variable 'bridge-prompt-regexp) + (make-local-variable 'bridge-handlers) + (make-local-variable 'bridge-source-insert) + (make-local-variable 'bridge-destination-insert) + (make-local-variable 'bridge-chunk-size) + (make-local-variable 'bridge-old-filter) + (make-local-variable 'bridge-string) + (make-local-variable 'bridge-in-progress) + (make-local-variable 'bridge-send-to-buffer) + (make-local-variable 'bridge-leftovers) + (setq bridge-string nil bridge-in-progress nil + bridge-send-to-buffer nil) + (if (boundp 'comint-prompt-regexp) + (setq bridge-prompt-regexp comint-prompt-regexp)) + (let ((process (get-buffer-process (current-buffer)))) + (if process + (if (not (eq (process-filter process) 'bridge-filter)) + (progn + (setq bridge-old-filter (process-filter process)) + (set-process-filter process 'bridge-filter))) + (error "%s does not have a process" + (buffer-name (current-buffer))))) + (run-hooks 'bridge-hook) + (message "Process bridge is installed"))) + +;;; +(defun reset-bridge () + "Must be called from the process's buffer. Removes any active bridge." + (interactive) + ;; for when things get wedged + (if bridge-in-progress + (unwind-protect + (funcall bridge-in-progress (get-buffer-process + (current-buffer)) + nil) + (setq bridge-in-progress nil)) + (message "No bridge in progress."))) + +;;; +(defun remove-bridge () + "Remove bridge from the current buffer." + (interactive) + (let ((process (get-buffer-process (current-buffer)))) + (if (or (not process) (not (eq (process-filter process) 'bridge-filter))) + (error "%s has no bridge" (buffer-name (current-buffer))) + ;; remove any bridge-in-progress + (reset-bridge) + (set-process-filter process bridge-old-filter) + (funcall bridge-old-filter process bridge-string) + (message "Process bridge is removed.")))) + +;;;% Utility for testing +(defun hand-bridge (start end) + "With point at bridge-start, sends bridge-start + string + +bridge-end to bridge-filter. With prefix, use current region to send." + (interactive "r") + (let ((p0 (if current-prefix-arg (min start end) + (if (looking-at bridge-start-regexp) (point) + (error "Not looking at bridge-start-regexp")))) + (p1 (if current-prefix-arg (max start end) + (if (re-search-forward bridge-end-regexp nil t) + (point) (error "Didn't see bridge-end-regexp"))))) + + (bridge-filter (get-buffer-process (current-buffer)) + (buffer-substring-no-properties p0 p1)) + )) + +(provide 'bridge)
Added: branches/trunk-reorg/thirdparty/slime/contrib/inferior-slime.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/inferior-slime.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/inferior-slime.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,88 @@ +;;; inferior-slime.el --- Minor mode with Slime keys for comint buffers +;; +;; Author: Luke Gorrie luke@synap.se +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'inferior-slime))) +;; (add-hook 'inferior-lisp-mode-hook (lambda () (inferior-slime-mode 1))) + +(define-minor-mode inferior-slime-mode + "\<slime-mode-map>\ +Inferior SLIME mode: The Inferior Superior Lisp Mode for Emacs. + +This mode is intended for use with `inferior-lisp-mode'. It provides a +subset of the bindings from `slime-mode'. + +\{inferior-slime-mode-map}" + nil + nil + ;; Fake binding to coax `define-minor-mode' to create the keymap + '((" " 'undefined))) + +(add-to-list 'minor-mode-alist + '(inferior-slime-mode + (" Inf-Slime" slime-state-name))) + +(defun inferior-slime-return () + "Handle the return key in the inferior-lisp buffer. +The current input should only be sent if a whole expression has been +entered, i.e. the parenthesis are matched. + +A prefix argument disables this behaviour." + (interactive) + (if (or current-prefix-arg (inferior-slime-input-complete-p)) + (comint-send-input) + (insert "\n") + (inferior-slime-indent-line))) + +(defun inferior-slime-indent-line () + "Indent the current line, ignoring everything before the prompt." + (interactive) + (save-restriction + (let ((indent-start + (save-excursion + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (let ((inhibit-field-text-motion t)) + (beginning-of-line 1)) + (point)))) + (narrow-to-region indent-start (point-max))) + (lisp-indent-line))) + +(defun inferior-slime-input-complete-p () + "Return true if the input is complete in the inferior lisp buffer." + (slime-input-complete-p (process-mark (get-buffer-process (current-buffer))) + (point-max))) + +(defun inferior-slime-closing-return () + "Send the current expression to Lisp after closing any open lists." + (interactive) + (goto-char (point-max)) + (save-restriction + (narrow-to-region (process-mark (get-buffer-process (current-buffer))) + (point-max)) + (while (ignore-errors (save-excursion (backward-up-list 1) t)) + (insert ")"))) + (comint-send-input)) + +(defun inferior-slime-init-keymap () + (let ((map inferior-slime-mode-map)) + (define-key map [return] 'inferior-slime-return) + (define-key map [(control return)] 'inferior-slime-closing-return) + (define-key map [(meta control ?m)] 'inferior-slime-closing-return) + (define-key map "\C-c\C-d" slime-doc-map) + (define-key map "\C-c\C-w" slime-who-map) + (loop for (key command . keys) in slime-keys do + (destructuring-bind (&key prefixed inferior &allow-other-keys) keys + (when prefixed + (setq key (concat slime-prefix-key key))) + (when inferior + (define-key map key command)))))) + +(inferior-slime-init-keymap) + +(provide 'inferior-slime)
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-asdf.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-asdf.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-asdf.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,113 @@ +;;; slime-asdf.el -- ASDF support +;; +;; Authors: Daniel Barlow dan@telent.net +;; Marco Baringer mb@bese.it +;; Edi Weitz edi@agharta.de +;; and others +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path ".../slime/contrib") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-asdf))) +;; + +;; NOTE: `system-name' is a predefined variable in Emacs. Try to +;; avoid it as local variable 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 "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: ")) + (let* ((completion-ignore-case nil) + (system-names (slime-eval `(swank:list-asdf-systems))) + (alist (slime-bogus-completion-alist system-names))) + (completing-read prompt alist nil nil + (or initial-value (slime-find-asd system-names) "") + 'slime-system-history))) + +(defun slime-find-asd (system-names) + "Tries to find an ASDF system definition in the default +directory or in the directory belonging to the current buffer and +returns it if it's in `system-names'." + (let* ((asdf-systems-in-directory + (mapcar #'file-name-sans-extension + (directory-files + (file-name-directory (or default-directory + (buffer-file-name))) + nil ".asd$")))) + (loop for system in asdf-systems-in-directory + for candidate = (file-name-sans-extension system) + when (find candidate system-names :test #'string-equal) + do (return candidate)))) + +(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) + (slime-eval-async + `(swank:operate-on-system-for-emacs ,system ,operation ,@keyword-args) + (slime-make-compilation-finished-continuation (current-buffer)))) + +(defslime-repl-shortcut slime-repl-load/force-system ("force-load-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "LOAD-OP" :force t))) + (:one-liner "Recompile and load an ASDF system.")) + +(defslime-repl-shortcut slime-repl-load-system ("load-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "LOAD-OP"))) + (:one-liner "Compile (as needed) and load an ASDF system.")) + +(defslime-repl-shortcut slime-repl-test/force-system ("force-test-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "TEST-OP" :force t))) + (:one-liner "Compile (as needed) and force test an ASDF system.")) + +(defslime-repl-shortcut slime-repl-test-system ("test-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "TEST-OP"))) + (:one-liner "Compile (as needed) and test an ASDF system.")) + +(defslime-repl-shortcut slime-repl-compile-system ("compile-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "COMPILE-OP"))) + (:one-liner "Compile (but not load) an ASDF system.")) + +(defslime-repl-shortcut slime-repl-compile/force-system + ("force-compile-system") + (:handler (lambda () + (interactive) + (slime-oos (slime-read-system-name) "COMPILE-OP" :force t))) + (:one-liner "Recompile (but not load) an ASDF system.")) + +(defun slime-asdf-on-connect () + (slime-eval-async '(swank:swank-require :swank-asdf))) + +(defun slime-asdf-init () + (add-hook 'slime-connected-hook 'slime-asdf-on-connect)) + +(defun slime-asdf-unload () + (remove-hook 'slime-connected-hook 'slime-asdf-on-connect)) + +(provide 'slime-asdf)
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,273 @@ +;;; slime-autodoc.el --- show fancy arglist in echo area +;; +;; Authors: Luke Gorrie luke@bluetail.com +;; Lawrence Mitchell wence@gmx.li +;; Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de +;; Tobias C. Rittweiler tcr@freebits.de +;; and others +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-autodoc))) +;; + +(require 'slime-parse) + +(defvar slime-use-autodoc-mode t + "When non-nil always enable slime-autodoc-mode in slime-mode.") + +(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-arglist (name) + "Show the argument list for NAME." + (interactive (list (slime-read-symbol-name "Arglist of: "))) + (slime-eval-async + `(swank:arglist-for-echo-area (quote (,name))) + (lambda (arglist) + (if arglist + (message "%s" (slime-fontify-string arglist)) + (error "Arglist not available"))))) + + + +;;;; Autodocs (automatic context-sensitive help) + +(defvar slime-autodoc-mode nil + "*When non-nil, print documentation about symbols as the point moves.") + +(defvar slime-autodoc-cache-type 'last + "*Cache policy for automatically fetched documentation. +Possible values are: + nil - none. + last - cache only the most recently-looked-at symbol's documentation. + The values are stored in the variable `slime-autodoc-cache'. + +More caching means fewer calls to the Lisp process, but at the risk of +using outdated information.") + +(defvar slime-autodoc-cache nil + "Cache variable for when `slime-autodoc-cache-type' is 'last'. +The value is (SYMBOL-NAME . DOCUMENTATION).") + +(defun slime-autodoc-mode (&optional arg) + "Enable `slime-autodoc'." + (interactive "P") + (cond ((< (prefix-numeric-value arg) 0) (setq slime-autodoc-mode nil)) + (arg (setq slime-autodoc-mode t)) + (t (setq slime-autodoc-mode (not slime-autodoc-mode)))) + (if slime-autodoc-mode + (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." + (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-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) + +(defvar slime-autodoc-message-function 'slime-autodoc-show-message) + +(defun slime-autodoc-message (doc) + "Display the autodoc documentation string DOC." + (funcall slime-autodoc-message-function doc)) + +(defun slime-autodoc-show-message (doc) + (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-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 points) + (slime-enclosing-form-specs) + (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*." + (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." + (ecase slime-autodoc-cache-type + ((nil) nil) + ((last) + (when (equal (car slime-autodoc-cache) symbol-name) + (cdr slime-autodoc-cache))) + ((all) + (when-let (symbol (intern-soft symbol-name)) + (get symbol 'slime-autodoc-cache))))) + +(defun slime-update-autodoc-cache (symbol-name documentation) + "Update the autodoc cache for SYMBOL with DOCUMENTATION. +Return DOCUMENTATION." + (ecase slime-autodoc-cache-type + ((nil) nil) + ((last) + (setq slime-autodoc-cache (cons symbol-name documentation))) + ((all) + (put (intern symbol-name) 'slime-autodoc-cache documentation))) + documentation) + + +;;;;; Asynchronous message idle timer + +(defvar slime-autodoc-idle-timer nil + "Idle timer for the next autodoc message.") + +(defvar slime-autodoc-delay 0.2 + "*Delay before autodoc messages are fetched and displayed, in seconds.") + +(defun slime-autodoc-start-timer () + "(Re)start the timer that prints autodocs every `slime-autodoc-delay' seconds." + (interactive) + (when slime-autodoc-idle-timer + (cancel-timer slime-autodoc-idle-timer)) + (setq slime-autodoc-idle-timer + (run-with-idle-timer slime-autodoc-delay slime-autodoc-delay + 'slime-autodoc-timer-hook))) + +(defun slime-autodoc-stop-timer () + "Stop the timer that prints autodocs. +See also `slime-autodoc-start-timer'." + (when slime-autodoc-idle-timer + (cancel-timer slime-autodoc-idle-timer) + (setq slime-autodoc-idle-timer nil))) + +(defun slime-autodoc-timer-hook () + "Function to be called after each Emacs becomes idle. +When `slime-autodoc-mode' is non-nil, print apropos information about +the symbol at point if applicable." + (when (slime-autodoc-message-ok-p) + (condition-case err + (slime-autodoc) + (error + (setq slime-autodoc-mode nil) + (message "Error: %S; slime-autodoc-mode now disabled." err))))) + +(defun slime-autodoc-message-ok-p () + "Return true if printing a message is currently okay (shouldn't +annoy the user)." + (and (or slime-mode (eq major-mode 'slime-repl-mode) + (eq major-mode 'sldb-mode)) + slime-autodoc-mode + (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) + (not (active-minibuffer-window)) + (not (eq (selected-window) (minibuffer-window))) + (slime-background-activities-enabled-p))) + + +;;; Initialization + +(defun slime-autodoc-init () + (setq slime-echo-arglist-function 'slime-autodoc) + (add-hook 'slime-connected-hook 'slime-autodoc-on-connect) + (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook)) + (add-hook h 'slime-autodoc-maybe-enable))) + +(defun slime-autodoc-on-connect () + (slime-eval-async '(swank:swank-require :swank-arglists))) + +(defun slime-autodoc-maybe-enable () + (when slime-use-autodoc-mode + (slime-autodoc-mode 1))) + +(defun slime-autodoc-unload () + (setq slime-echo-arglist-function 'slime-show-arglist) + (remove-hook 'slime-connected-hook 'slime-autodoc-on-connect) + (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook)) + (remove-hook h 'slime-autodoc-maybe-enable))) + +(provide 'slime-autodoc)
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-banner.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-banner.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-banner.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,44 @@ +;;; slime-banner.el -- Persistent header line and startup animation +;; +;; Authors: Helmut Eller heller@common-lisp.net +;; Luke Gorrie luke@synap.se +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path ".../slime/contrib") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-banner))) + +(defcustom slime-startup-animation (fboundp 'animate-string) + "Enable the startup animation." + :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) + :group 'slime-ui) + +(defcustom slime-header-line-p (boundp 'header-line-format) + "If non-nil, display a header line in Slime buffers." + :type 'boolean + :group 'slime-repl) + +(defun slime-startup-message () + (when slime-header-line-p + (setq header-line-format + (format "%s Port: %s Pid: %s" + (slime-lisp-implementation-type) + (slime-connection-port (slime-connection)) + (slime-pid)))) + (when (zerop (buffer-size)) + (let ((welcome (concat "; SLIME " (or (slime-changelog-date) + "- ChangeLog file not found")))) + (if slime-startup-animation + (animate-string welcome 0 0) + (insert welcome))))) + +(defun slime-banner-init () + (setq slime-repl-banner-function 'slime-startup-message)) + +(defun slime-banner-unload () + (setq slime-repl-banner-function 'slime-repl-insert-banner)) + +(provide 'slime-banner)
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,202 @@ +;;; slime-c-p-c.el --- ILISP style Compound Prefix Completion +;; +;; Authors: Luke Gorrie luke@synap.se +;; Edi Weitz edi@agharta.de +;; Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de +;; Tobias C. Rittweiler tcr@freebits.de +;; and others +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-c-p-c))) +;; + + + +(require 'slime) +(require 'slime-parse) +(require 'slime-editing-commands) + +(defcustom slime-c-p-c-unambiguous-prefix-p t + "If true, set point after the unambigous prefix. +If false, move point to the end of the inserted text." + :type 'boolean + :group 'slime-ui) + +(defcustom slime-complete-symbol*-fancy nil + "Use information from argument lists for DWIM'ish symbol completion." + :group 'slime-mode + :type 'boolean) + +(defun slime-complete-symbol* () + "Expand abbreviations and complete the symbol at point." + ;; NB: It is only the name part of the symbol that we actually want + ;; to complete -- the package prefix, if given, is just context. + (or (slime-maybe-complete-as-filename) + (slime-expand-abbreviations-and-complete))) + +;; FIXME: factorize +(defun slime-expand-abbreviations-and-complete () + (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) + (beg (move-marker (make-marker) (slime-symbol-start-pos))) + (prefix (buffer-substring-no-properties beg end)) + (completion-result (slime-contextual-completions beg end)) + (completion-set (first completion-result)) + (completed-prefix (second completion-result))) + (if (null completion-set) + (progn (slime-minibuffer-respecting-message + "Can't find completion for "%s"" prefix) + (ding) + (slime-complete-restore-window-configuration)) + ;; some XEmacs issue makes this distinction necessary + (cond ((> (length completed-prefix) (- end beg)) + (goto-char end) + (insert-and-inherit completed-prefix) + (delete-region beg end) + (goto-char (+ beg (length completed-prefix)))) + (t nil)) + (cond ((and (member completed-prefix completion-set) + (slime-length= completion-set 1)) + (slime-minibuffer-respecting-message "Sole completion") + (when slime-complete-symbol*-fancy + (slime-complete-symbol*-fancy-bit)) + (slime-complete-restore-window-configuration)) + ;; Incomplete + (t + (when (member completed-prefix completion-set) + (slime-minibuffer-respecting-message + "Complete but not unique")) + (when slime-c-p-c-unambiguous-prefix-p + (let ((unambiguous-completion-length + (loop for c in completion-set + minimizing (or (mismatch completed-prefix c) + (length completed-prefix))))) + (goto-char (+ beg unambiguous-completion-length)))) + (slime-display-or-scroll-completions completion-set + completed-prefix)))))) + +(defun slime-complete-symbol*-fancy-bit () + "Do fancy tricks after completing a symbol. +(Insert a space or close-paren based on arglist information.)" + (let ((arglist (slime-get-arglist (slime-symbol-name-at-point)))) + (when arglist + (let ((args + ;; Don't intern these symbols + (let ((obarray (make-vector 10 0))) + (cdr (read arglist)))) + (function-call-position-p + (save-excursion + (backward-sexp) + (equal (char-before) ?()))) + (when function-call-position-p + (if (null args) + (insert-and-inherit ")") + (insert-and-inherit " ") + (when (and slime-space-information-p + (slime-background-activities-enabled-p) + (not (minibuffer-window-active-p (minibuffer-window)))) + (slime-echo-arglist)))))))) + +(defun slime-get-arglist (symbol-name) + "Return the argument list for SYMBOL-NAME." + (slime-eval `(swank:arglist-for-echo-area (quote (,symbol-name))))) + +(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 points) + (save-excursion + (goto-char beg) + (slime-enclosing-form-specs)) + (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)))) + +(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))) + + +;;; Complete form + +(defun slime-complete-form () + "Complete the form at point. +This is a superset of the functionality of `slime-insert-arglist'." + (interactive) + ;; Find the (possibly incomplete) form around point. + (let ((form-string (slime-incomplete-form-at-point))) + (let ((result (slime-eval `(swank:complete-form ',form-string)))) + (if (eq result :not-available) + (error "Could not generate completion for the form `%s'" form-string) + (progn + (just-one-space) + (save-excursion + ;; SWANK:COMPLETE-FORM always returns a closing + ;; parenthesis; but we only want to insert one if it's + ;; really necessary (thinking especially of paredit.el.) + (insert (substring result 0 -1)) + (let ((slime-close-parens-limit 1)) + (slime-close-all-parens-in-sexp))) + (save-excursion + (backward-up-list 1) + (indent-sexp))))))) + +;;; Initialization + +(defvar slime-c-p-c-init-undo-stack nil) + +(defun slime-c-p-c-init () + ;; save current state for unload + (push + `(progn + (setq slime-complete-symbol-function ',slime-complete-symbol-function) + (remove-hook 'slime-connected-hook 'slime-c-p-c-on-connect) + (define-key slime-mode-map "\C-c\C-s" + ',(lookup-key slime-mode-map "\C-c\C-s")) + (define-key slime-repl-mode-map "\C-c\C-s" + ',(lookup-key slime-repl-mode-map "\C-c\C-s"))) + slime-c-p-c-init-undo-stack) + (setq slime-complete-symbol-function 'slime-complete-symbol*) + (add-hook 'slime-connected-hook 'slime-c-p-c-on-connect) + (define-key slime-mode-map "\C-c\C-s" 'slime-complete-form) + (define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form)) + +(defun slime-c-p-c-on-connect () + (slime-eval-async '(swank:swank-require :swank-arglists))) + +(defun slime-c-p-c-unload () + (while slime-c-p-c-init-undo-stack + (eval (pop slime-c-p-c-init-undo-stack)))) + +(provide 'slime-c-p-c)
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,189 @@ +;;; slime-editing-commands.el -- editing commands whithout server interaction +;; +;; Authors: Thomas F. Burdick tfb@OCF.Berkeley.EDU +;; Luke Gorrie luke@synap.se +;; Bill Clementson billclem@gmail.com +;; Tobias C. Rittweiler tcr@freebits.de +;; and others +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-editing-commands))) +;; + +(defun slime-beginning-of-defun () + (interactive) + (if (and (boundp 'slime-repl-input-start-mark) + slime-repl-input-start-mark) + (slime-repl-beginning-of-defun) + (beginning-of-defun))) + +(defun slime-end-of-defun () + (interactive) + (if (and (boundp 'slime-repl-input-end-mark) + slime-repl-input-end-mark) + (slime-repl-end-of-defun) + (end-of-defun))) + +(defvar slime-comment-start-regexp + "\(\(^\|[^\n\\]\)\([\\][\\]\)*\);+[ \t]*" + "Regexp to match the start of a comment.") + +(defun slime-beginning-of-comment () + "Move point to beginning of comment. +If point is inside a comment move to beginning of comment and return point. +Otherwise leave point unchanged and return NIL." + (let ((boundary (point))) + (beginning-of-line) + (cond ((re-search-forward slime-comment-start-regexp boundary t) + (point)) + (t (goto-char boundary) + nil)))) + +(defun slime-close-all-parens-in-sexp (&optional region) + "Balance parentheses of open s-expressions at point. +Insert enough right parentheses to balance unmatched left parentheses. +Delete extra left parentheses. Reformat trailing parentheses +Lisp-stylishly. + +If REGION is true, operate on the region. Otherwise operate on +the top-level sexp before point." + (interactive "P") + (let ((sexp-level 0) + point) + (save-excursion + (save-restriction + (when region + (narrow-to-region (region-beginning) (region-end)) + (goto-char (point-max))) + ;; skip over closing parens, but not into comment + (skip-chars-backward ") \t\n") + (when (slime-beginning-of-comment) + (forward-line) + (skip-chars-forward " \t")) + (setq point (point)) + ;; count sexps until either '(' or comment is found at first column + (while (and (not (looking-at "^[(;]")) + (ignore-errors (backward-up-list 1) t)) + (incf sexp-level)))) + (when (> sexp-level 0) + ;; insert correct number of right parens + (goto-char point) + (dotimes (i sexp-level) (insert ")")) + ;; delete extra right parens + (setq point (point)) + (skip-chars-forward " \t\n)") + (skip-chars-backward " \t\n") + (let* ((deleted-region (delete-and-extract-region point (point))) + (deleted-text (substring-no-properties deleted-region)) + (prior-parens-count (count ?) deleted-text))) + ;; Remember: we always insert as many parentheses as necessary + ;; and only afterwards delete the superfluously-added parens. + (when slime-close-parens-limit + (let ((missing-parens (- sexp-level prior-parens-count + slime-close-parens-limit))) + (dotimes (i (max 0 missing-parens)) + (delete-char -1)))))))) + +(defvar slime-close-parens-limit nil + "Maxmimum parens for `slime-close-all-sexp' to insert. NIL +means to insert as many parentheses as necessary to correctly +close the form.") + +(defun slime-insert-balanced-comments (arg) + "Insert a set of balanced comments around the s-expression +containing the point. If this command is invoked repeatedly +(without any other command occurring between invocations), the +comment progressively moves outward over enclosing expressions. +If invoked with a positive prefix argument, the s-expression arg +expressions out is enclosed in a set of balanced comments." + (interactive "*p") + (save-excursion + (when (eq last-command this-command) + (when (search-backward "#|" nil t) + (save-excursion + (delete-char 2) + (while (and (< (point) (point-max)) (not (looking-at " *|#"))) + (forward-sexp)) + (replace-match "")))) + (while (> arg 0) + (backward-char 1) + (cond ((looking-at ")") (incf arg)) + ((looking-at "(") (decf arg)))) + (insert "#|") + (forward-sexp) + (insert "|#"))) + +(defun slime-remove-balanced-comments () + "Remove a set of balanced comments enclosing point." + (interactive "*") + (save-excursion + (when (search-backward "#|" nil t) + (delete-char 2) + (while (and (< (point) (point-max)) (not (looking-at " *|#"))) + (forward-sexp)) + (replace-match "")))) + + +;; SLIME-CLOSE-PARENS-AT-POINT is obsolete: + +;; It doesn't work correctly on the REPL, because there +;; BEGINNING-OF-DEFUN-FUNCTION and END-OF-DEFUN-FUNCTION is bound to +;; SLIME-REPL-MODE-BEGINNING-OF-DEFUN (and +;; SLIME-REPL-MODE-END-OF-DEFUN respectively) which compromises the +;; way how they're expect to work (i.e. END-OF-DEFUN does not signal +;; an UNBOUND-PARENTHESES error.) + +;; Use SLIME-CLOSE-ALL-PARENS-IN-SEXP instead. + +;; (defun slime-close-parens-at-point () +;; "Close parenthesis at point to complete the top-level-form. Simply +;; inserts ')' characters at point until `beginning-of-defun' and +;; `end-of-defun' execute without errors, or `slime-close-parens-limit' +;; is exceeded." +;; (interactive) +;; (loop for i from 1 to slime-close-parens-limit +;; until (save-excursion +;; (slime-beginning-of-defun) +;; (ignore-errors (slime-end-of-defun) t)) +;; do (insert ")"))) + +(defun slime-reindent-defun (&optional force-text-fill) + "Reindent the current defun, or refill the current paragraph. +If point is inside a comment block, the text around point will be +treated as a paragraph and will be filled with `fill-paragraph'. +Otherwise, it will be treated as Lisp code, and the current defun +will be reindented. If the current defun has unbalanced parens, +an attempt will be made to fix it before reindenting. + +When given a prefix argument, the text around point will always +be treated as a paragraph. This is useful for filling docstrings." + (interactive "P") + (save-excursion + (if (or force-text-fill (slime-beginning-of-comment)) + (fill-paragraph nil) + (let ((start (progn (unless (or (and (zerop (current-column)) + (eq ?( (char-after))) + (and slime-repl-input-start-mark + (slime-repl-at-prompt-start-p))) + (slime-beginning-of-defun)) + (point))) + (end (ignore-errors (slime-end-of-defun) (point)))) + (unless end + (forward-paragraph) + (slime-close-all-parens-in-sexp) + (slime-end-of-defun) + (setf end (point))) + (indent-region start end nil))))) + +(defun slime-editing-commands-init () + (define-key slime-mode-map "\M-\C-a" 'slime-beginning-of-defun) + (define-key slime-mode-map "\M-\C-e" 'slime-end-of-defun) + (define-key slime-mode-map "\C-c\M-q" 'slime-reindent-defun)) + +(provide 'slime-editing-commands)
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,28 @@ +;;; slime-fancy-inspector.el --- Fancy inspector for CLOS objects +;; +;; Author: Marco Baringer mb@bese.it and others +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-fancy-inspector))) +;; (add-hook 'slime-connected-hook 'slime-install-fancy-inspector) + +(defun slime-install-fancy-inspector () + (slime-eval-async '(swank:swank-require :swank-fancy-inspector) + (lambda (_) + (slime-eval-async '(swank:fancy-inspector-init))))) + +(defun slime-deinstall-fancy-inspector () + (slime-eval-async '(swank:fancy-inspector-unload))) + +(defun slime-fancy-inspector-init () + (add-hook 'slime-connected-hook 'slime-install-fancy-inspector)) + +(defun slime-fancy-inspector-unload () + (remove-hook 'slime-connected-hook 'slime-install-fancy-inspector)) + +(provide 'slime-fancy-inspector) \ No newline at end of file
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,74 @@ +;;; slime-fancy.el --- Load and init some fancy SLIME contribs +;; +;; Authors: Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-fancy))) +;; +;; We load all SLIME contribs that are currently working, +;; and which only "upgrade" the behavior of SLIME in some way. +;; This includes: +;; * Adding new commands, keybindings, menu items +;; * Making things clickable that would otherwise be just plain text + +;; Better arglist display, can be turned off by customization. +(require 'slime-autodoc) +(slime-autodoc-init) + +;; Adds new commands and installs compound-prefix-completion as +;; default completion command. Behaves similar to standard Emacs +;; completion, unless dashes are present. --mkoeppe +(require 'slime-c-p-c) +(slime-c-p-c-init) + +;; Just adds commands. (Well, shadows commands in lisp-mode-map) +(require 'slime-editing-commands) +(slime-editing-commands-init) + +;; Makes the inspector fancier. +(require 'slime-fancy-inspector) +(slime-fancy-inspector-init) + +;; Just adds the command C-c M-i. We do not make fuzzy completion the +;; default completion invoked by TAB. --mkoeppe +(require 'slime-fuzzy) +(slime-fuzzy-init) + +;; Do not activate slime-highlighting-edits by default, as it's easier +;; to explictly activate it (if a user really wants it) than to explictly +;; deactivate it once it got globally enabled. -TCR. +(require 'slime-highlight-edits) +;(slime-highlight-edits-init) + +;; Load slime-presentations even though they seem to be a +;; controversial feature, as they can be easily turned off by +;; customizing swank:*record-repl-results*. --mkoeppe +(require 'slime-presentations) +(slime-presentations-init) + +;;; Do not load slime-presentation-streams, as this is an experimental +;;; feature that installs patches into some Lisps. --mkoeppe +;;(require 'slime-presentation-streams) + +(require 'slime-scratch) +(slime-scratch-init) + +;;; Do not load slime-typeout-frame, as simply loading causes display of a +;;; typeout frame, which cannot be turned off. --mkoeppe +;;(require 'slime-typeout-frame) + +;; Just adds commands. +(when (locate-library "tree-widget") + (require 'slime-xref-browser)) + +;; Puts clickable references to documentation into SBCL errors. +(require 'slime-references) +(slime-references-init) + +(provide 'slime-fancy)
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,598 @@ +;;; slime-fuzzy.el --- fuzzy symbol completion +;; +;; Authors: Brian Downing bdowning@lavos.net +;; Tobias C. Rittweiler tcr@freebits.de +;; Attila Lendvai attila.lendvai@gmail.com +;; and others +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-fuzzy))) +;; + + +;;; Code + +(defcustom slime-fuzzy-completion-in-place t + "When non-NIL the fuzzy symbol completion is done in place as +opposed to moving the point to the completion buffer." + :group 'slime-mode + :type 'boolean) + +(defcustom slime-fuzzy-completion-limit 300 + "Only return and present this many symbols from swank." + :group 'slime-mode + :type 'integer) + +(defcustom slime-fuzzy-completion-time-limit-in-msec 1500 + "Limit the time spent (given in msec) in swank while gathering comletitions. +(NOTE: currently it's rounded up the nearest second)" + :group 'slime-mode + :type 'integer) + +(defvar slime-fuzzy-target-buffer nil + "The buffer that is the target of the completion activities.") +(defvar slime-fuzzy-saved-window-configuration nil + "The saved window configuration before the fuzzy completion +buffer popped up.") +(defvar slime-fuzzy-start nil + "The beginning of the completion slot in the target buffer. +This is a non-advancing marker.") +(defvar slime-fuzzy-end nil + "The end of the completion slot in the target buffer. +This is an advancing marker.") +(defvar slime-fuzzy-original-text nil + "The original text that was in the completion slot in the +target buffer. This is what is put back if completion is +aborted.") +(defvar slime-fuzzy-text nil + "The text that is currently in the completion slot in the +target buffer. If this ever doesn't match, the target buffer has +been modified and we abort without touching it.") +(defvar slime-fuzzy-first nil + "The position of the first completion in the completions buffer. +The descriptive text and headers are above this.") +(defvar slime-fuzzy-last nil + "The position of the last completion in the completions buffer. +If the time limit has exhausted during generation possible completion +choices inside SWANK, an indication is printed below this.") +(defvar slime-fuzzy-current-completion nil + "The current completion object. If this is the same before and +after point moves in the completions buffer, the text is not +replaced in the target for efficiency.") +(defvar slime-fuzzy-current-completion-overlay nil + "The overlay representing the current completion in the completion +buffer. This is used to hightlight the text.") + +;;;;;;; slime-target-buffer-fuzzy-completions-mode +;; NOTE: this mode has to be able to override key mappings in slime-mode + +;; FIXME: clean this up + +(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 "<return>") (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.") + +;; Make sure slime-fuzzy-target-buffer-completions-mode's map is +;; before everything else. +(setf minor-mode-map-alist + (stable-sort minor-mode-map-alist + (lambda (a b) + (eq a 'slime-fuzzy-target-buffer-completions-mode)) + :key #'car)) + + +(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")) + +(define-derived-mode slime-fuzzy-completions-mode + fundamental-mode "Fuzzy Completions" + "Major mode for presenting fuzzy completion results. + +When you run `slime-fuzzy-complete-symbol', the symbol token at +point is completed using the Fuzzy Completion algorithm; this +means that the token is taken as a sequence of characters and all +the various possibilities that this sequence could meaningfully +represent are offered as selectable choices, sorted by how well +they deem to be a match for the token. (For instance, the first +choice of completing on "mvb" would be "multiple-value-bind".) + +Therefore, a new buffer (*Fuzzy Completions*) will pop up that +contains the different completion choices. Simultaneously, a +special minor-mode will be temporarily enabled in the original +buffer where you initiated fuzzy completion (also called the +``target buffer'') in order to navigate through the *Fuzzy +Completions* buffer without leaving. + +With focus in *Fuzzy Completions*: + Type `n' and `p' (`UP', `DOWN') to navigate between completions. + Type `RET' or `TAB' to select the completion near point. + Type `q' to abort. + +With focus in the target buffer: + Type `UP' and `DOWN' to navigate between completions. + Type a character that does not constitute a symbol name + to insert the current choice and then that character (`(', `)', + `SPACE', `RET'.) Use `TAB' to simply insert the current choice. + Use C-g to abort. + +Alternatively, you can click <mouse-2> on a completion to select it. + + +Complete listing of keybindings within the target buffer: + +\<slime-target-buffer-fuzzy-completions-map>\ +\{slime-target-buffer-fuzzy-completions-map} + +Complete listing of keybindings with *Fuzzy Completions*: + +\<slime-fuzzy-completions-map>\ +\{slime-fuzzy-completions-map}" + (use-local-map slime-fuzzy-completions-map)) + +(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) + + (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 "p" 'slime-fuzzy-prev) + (define-key map "\M-p" 'slime-fuzzy-prev) + + (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 (kbd "RET") 'slime-fuzzy-select) + (define-key map (kbd "<SPC>") 'slime-fuzzy-select) + + map) + "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 +`prefix' in `package' from the connected Lisp." + (let ((prefix (etypecase prefix + (symbol (symbol-name prefix)) + (string prefix)))) + (slime-eval `(swank:fuzzy-completions ,prefix + ,(or default-package + (slime-find-buffer-package) + (slime-current-package)) + :limit ,slime-fuzzy-completion-limit + :time-limit-in-msec ,slime-fuzzy-completion-time-limit-in-msec)))) + +(defun slime-fuzzy-selected (prefix completion) + "Tell the connected Lisp that the user selected completion +`completion' as the completion for `prefix'." + (let ((no-properties (copy-sequence prefix))) + (set-text-properties 0 (length no-properties) nil no-properties) + (slime-eval `(swank:fuzzy-completion-selected ,no-properties + ',completion)))) + +(defun slime-fuzzy-indent-and-complete-symbol () + "Indent the current line and perform fuzzy symbol completion. First +indent the line. If indenting doesn't move point, complete the +symbol. If there's no symbol at the point, show the arglist for the +most recently enclosed macro or function." + (interactive) + (let ((pos (point))) + (unless (get-text-property (line-beginning-position) 'slime-repl-prompt) + (lisp-indent-line)) + (when (= pos (point)) + (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\=" nil t)) + (slime-fuzzy-complete-symbol)) + ((memq (char-before) '(?\t ?\ )) + (slime-echo-arglist)))))) + +(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 + (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))) + (destructuring-bind (completion-set interrupted-p) + (slime-fuzzy-completions prefix) + (if (null completion-set) + (progn (slime-minibuffer-respecting-message + "Can't find completion for "%s"" prefix) + (ding) + (slime-fuzzy-done)) + (goto-char end) + (cond ((slime-length= completion-set 1) + (insert-and-inherit (caar completion-set)) ; insert completed string + (delete-region beg end) + (goto-char (+ beg (length (caar completion-set)))) + (slime-minibuffer-respecting-message "Sole completion") + (slime-fuzzy-done)) + ;; Incomplete + (t + (slime-minibuffer-respecting-message "Complete but not unique") + (slime-fuzzy-choices-buffer completion-set interrupted-p beg end))))))) + + +(defun slime-get-fuzzy-buffer () + (get-buffer-create "*Fuzzy Completions*")) + +(defvar slime-fuzzy-explanation + "For help on how the use this buffer, see `slime-fuzzy-completions-mode'. + +Flags: boundp fboundp generic-function class macro special-operator package +\n" + "The explanation that gets inserted at the beginning of the +*Fuzzy Completions* buffer.") + +(defun slime-fuzzy-insert-completion-choice (completion max-length) + "Inserts the completion object `completion' as a formatted +completion choice into the current buffer, and mark it with the +proper text properties." + (let ((start (point)) + (symbol-name (first completion)) + (score (second completion)) + (chunks (third completion)) + (flags (fourth completion))) + (insert symbol-name) + (let ((end (point))) + (dolist (chunk chunks) + (put-text-property (+ start (first chunk)) + (+ start (first chunk) + (length (second chunk))) + 'face 'bold)) + (put-text-property start (point) 'mouse-face 'highlight) + (dotimes (i (- max-length (- end start))) + (insert " ")) + (insert (format " %s%s%s%s%s%s%s %8.2f" + (if (member :boundp flags) "b" "-") + (if (member :fboundp flags) "f" "-") + (if (member :generic-function flags) "g" "-") + (if (member :class flags) "c" "-") + (if (member :macro flags) "m" "-") + (if (member :special-operator flags) "s" "-") + (if (member :package flags) "p" "-") + score)) + (insert "\n") + (put-text-property start (point) 'completion completion)))) + +(defun slime-fuzzy-insert (text) + "Inserts `text' into the target buffer in the completion slot. +If the buffer has been modified in the meantime, abort the +completion process. Otherwise, update all completion variables +so that the new text is present." + (with-current-buffer slime-fuzzy-target-buffer + (cond + ((not (string-equal slime-fuzzy-text + (buffer-substring slime-fuzzy-start + slime-fuzzy-end))) + (slime-fuzzy-done) + (beep) + (message "Target buffer has been modified!")) + (t + (goto-char slime-fuzzy-start) + (delete-region slime-fuzzy-start slime-fuzzy-end) + (insert-and-inherit text) + (setq slime-fuzzy-text text) + (goto-char slime-fuzzy-end))))) + +(defun slime-fuzzy-choices-buffer (completions interrupted-p start end) + "Creates (if neccessary), populates, and pops up the *Fuzzy +Completions* buffer with the completions from `completions' and +the completion slot in the current buffer bounded by `start' and +`end'. This saves the window configuration before popping the +buffer so that it can possibly be restored when the user is +done." + (let ((new-completion-buffer (not slime-fuzzy-target-buffer))) + (when new-completion-buffer + (setq slime-fuzzy-saved-window-configuration + (current-window-configuration))) + (slime-fuzzy-enable-target-buffer-completions-mode) + (setq slime-fuzzy-target-buffer (current-buffer)) + (setq slime-fuzzy-start (move-marker (make-marker) start)) + (setq slime-fuzzy-end (move-marker (make-marker) end)) + (set-marker-insertion-type slime-fuzzy-end t) + (setq slime-fuzzy-original-text (buffer-substring start end)) + (setq slime-fuzzy-text slime-fuzzy-original-text) + (slime-fuzzy-fill-completions-buffer completions interrupted-p) + (pop-to-buffer (slime-get-fuzzy-buffer)) + (when new-completion-buffer + ;; Hook to nullify window-config restoration if the user changes + ;; the window configuration himself. + (when (boundp 'window-configuration-change-hook) + (add-hook 'window-configuration-change-hook + 'slime-fuzzy-window-configuration-change)) + (add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort) + (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc + (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 interrupted-p) + "Erases and fills the completion buffer with the given completions." + (with-current-buffer (slime-get-fuzzy-buffer) + (setq buffer-read-only nil) + (erase-buffer) + (slime-fuzzy-completions-mode) + (insert slime-fuzzy-explanation) + (let ((max-length 12)) + (dolist (completion completions) + (setf max-length (max max-length (length (first completion))))) + + (insert "Completion:") + (dotimes (i (- max-length 10)) (insert " ")) + ;; Flags: Score: + ;; ... ------- -------- + ;; bfgcmsp + (insert "Flags: Score:\n") + (dotimes (i max-length) (insert "-")) + (insert " ------- --------\n") + (setq slime-fuzzy-first (point)) + + (dolist (completion completions) + (setq slime-fuzzy-last (point)) ; will eventually become the last entry + (slime-fuzzy-insert-completion-choice completion max-length)) + + (when interrupted-p + (insert "...\n") + (insert "[Interrupted: time limit exhausted]")) + + (setq buffer-read-only t)) + (setq slime-fuzzy-current-completion + (caar completions)) + (goto-char 0) + (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 +already been inserted, it does nothing." + (with-current-buffer (slime-get-fuzzy-buffer) + (let ((current-completion (get-text-property (point) 'completion))) + (when (and current-completion + (not (eq slime-fuzzy-current-completion + current-completion))) + (slime-fuzzy-insert + (first (get-text-property (point) 'completion))) + (setq slime-fuzzy-current-completion + current-completion))))) + +(defun slime-fuzzy-post-command-hook () + "The post-command-hook for the *Fuzzy Completions* buffer. +This makes sure the completion slot in the target buffer matches +the completion that point is on in the completions buffer." + (condition-case err + (when slime-fuzzy-target-buffer + (slime-fuzzy-insert-from-point)) + (error + ;; Because this is called on the post-command-hook, we mustn't let + ;; errors propagate. + (message "Error in slime-fuzzy-post-command-hook: %S" err)))) + +(defun slime-fuzzy-next () + "Moves point directly to the next completion in the completions +buffer." + (interactive) + (with-current-buffer (slime-get-fuzzy-buffer) + (slime-fuzzy-dehighlight-current-completion) + (let ((point (next-single-char-property-change (point) 'completion nil slime-fuzzy-last))) + (set-window-point (get-buffer-window (current-buffer)) point) + (goto-char point)) + (slime-fuzzy-highlight-current-completion))) + +(defun slime-fuzzy-prev () + "Moves point directly to the previous completion in the +completions buffer." + (interactive) + (with-current-buffer (slime-get-fuzzy-buffer) + (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) (1- (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-done))) + +(defun slime-fuzzy-select () + "Selects the current completion, making sure that it is inserted +into the target buffer. This tells the connected Lisp what completion +was selected." + (interactive) + (when slime-fuzzy-target-buffer + (with-current-buffer (slime-get-fuzzy-buffer) + (let ((completion (get-text-property (point) 'completion))) + (when completion + (slime-fuzzy-insert (first completion)) + (slime-fuzzy-selected slime-fuzzy-original-text + completion) + (slime-fuzzy-done)))))) + +(defun slime-fuzzy-select-or-update-completions () + "If there were no changes since the last time fuzzy completion was started +this function will select the current completion. Otherwise refreshes the completion +list based on the changes made." + (interactive) +; (slime-log-event "Selecting or updating completions") + (if (string-equal slime-fuzzy-original-text + (buffer-substring slime-fuzzy-start + slime-fuzzy-end)) + (slime-fuzzy-select) + (slime-fuzzy-complete-symbol))) + +(defun slime-fuzzy-process-event-in-completions-buffer () + "Simply processes the event in the target buffer" + (interactive) + (with-current-buffer (slime-get-fuzzy-buffer) + (push last-input-event unread-command-events))) + +(defun slime-fuzzy-select-and-process-event-in-target-buffer () + "Selects the current completion, making sure that it is inserted +into the target buffer and processes the event in the target buffer." + (interactive) +; (slime-log-event "Selecting and processing event in target buffer") + (when slime-fuzzy-target-buffer + (let ((buff slime-fuzzy-target-buffer)) + (slime-fuzzy-select) + (with-current-buffer buff + (slime-fuzzy-disable-target-buffer-completions-mode) + (push last-input-event unread-command-events))))) + +(defun slime-fuzzy-select/mouse (event) + "Handle a mouse-2 click on a completion choice as if point were +on the completion choice and the slime-fuzzy-select command was +run." + (interactive "e") + (with-current-buffer (window-buffer (posn-window (event-end event))) + (save-excursion + (goto-char (posn-point (event-end event))) + (when (get-text-property (point) 'mouse-face) + (slime-fuzzy-insert-from-point) + (slime-fuzzy-select))))) + +(defun slime-fuzzy-done () + "Cleans up after the completion process. This removes all hooks, +and attempts to restore the window configuration. If this fails, +it just burys the completions buffer and leaves the window +configuration alone." + (when slime-fuzzy-target-buffer + (set-buffer slime-fuzzy-target-buffer) + (slime-fuzzy-disable-target-buffer-completions-mode) + (if (slime-fuzzy-maybe-restore-window-configuration) + (bury-buffer (slime-get-fuzzy-buffer)) + ;; We couldn't restore the windows, so just bury the fuzzy + ;; completions buffer and let something else fill it in. + (pop-to-buffer (slime-get-fuzzy-buffer)) + (bury-buffer)) + (pop-to-buffer slime-fuzzy-target-buffer) + (goto-char slime-fuzzy-end) + (setq slime-fuzzy-target-buffer nil) + (remove-hook 'window-configuration-change-hook + 'slime-fuzzy-window-configuration-change))) + +(defun slime-fuzzy-maybe-restore-window-configuration () + "Restores the saved window configuration if it has not been +nullified." + (when (boundp 'window-configuration-change-hook) + (remove-hook 'window-configuration-change-hook + 'slime-fuzzy-window-configuration-change)) + (if (not slime-fuzzy-saved-window-configuration) + nil + (set-window-configuration slime-fuzzy-saved-window-configuration) + (setq slime-fuzzy-saved-window-configuration nil) + t)) + +(defun slime-fuzzy-window-configuration-change () + "Called on window-configuration-change-hook. Since the window +configuration was changed, we nullify our saved configuration." + (setq slime-fuzzy-saved-window-configuration nil)) + +;;; Initialization + +(defun slime-fuzzy-init () + (add-hook 'slime-connected-hook 'slime-fuzzy-on-connect) + (slime-fuzzy-bind-keys)) + +(defun slime-fuzzy-bind-keys () + (define-key slime-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol) + (define-key slime-repl-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol)) + +(defun slime-fuzzy-on-connect () + (slime-eval-async '(swank:swank-require :swank-fuzzy))) + +(provide 'slime-fuzzy)
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-highlight-edits.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-highlight-edits.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-highlight-edits.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,99 @@ +;;; slime-higlight-edits --- highlight edited, i.e. not yet compiled, code +;; +;; Author: William Bland doctorbill.news@gmail.com and others +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this your .emacs: +;; +;; (add-to-list 'load-path "<contrib-dir>") +;; (autoload 'slime-highlight-edits-mode "slime-highlight-edits") +;; (add-hook 'slime-mode-hook (lambda () (slime-highlight-edits-mode 1))) + +(defface slime-highlight-edits-face + `((((class color) (background light)) + (:background "lightgray")) + (((class color) (background dark)) + (:background "dimgray")) + (t (:background "yellow"))) + "Face for displaying edit but not compiled code." + :group 'slime-mode-faces) + +(define-minor-mode slime-highlight-edits-mode + "Minor mode to highlight not-yet-compiled code." nil) + +(add-hook 'slime-highlight-edits-mode-on-hook + 'slime-highlight-edits-init-buffer) + +(add-hook 'slime-highlight-edits-mode-off-hook + 'slime-highlight-edits-reset-buffer) + +(defun slime-highlight-edits-init-buffer () + (make-local-variable 'after-change-functions) + (add-to-list 'after-change-functions + 'slime-highlight-edits) + (add-to-list 'slime-before-compile-functions + 'slime-highlight-edits-compile-hook)) + +(defun slime-highlight-edits-reset-buffer () + (setq after-change-functions + (remove 'slime-highlight-edits after-change-functions)) + (slime-remove-edits (point-min) (point-max))) + +;; FIXME: what's the LEN arg for? +(defun slime-highlight-edits (beg end &optional len) + (save-match-data + (when (and (slime-connected-p) + (not (slime-inside-comment-p 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)))) + +(defun slime-highlight-edits-mode-on () (slime-highlight-edits-mode 1)) + +(defun slime-highlight-edits-init () + (add-hook 'slime-mode-hook 'slime-highlight-edits-mode-on)) + +(defun slime-highlight-edits-unload () + (remove-hook 'slime-mode-hook 'slime-highlight-edits-mode-on)) + +(provide 'slime-highlight-edits) \ No newline at end of file
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,378 @@ +;;; slime-parse.el --- parsing of Common Lisp source code +;; +;; Authors: Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de +;; Tobias C. Rittweiler tcr@freebits.de +;; and others +;; +;; License: GNU GPL (same license as Emacs) +;; + +(defun slime-incomplete-form-at-point () + "Looks for a ``raw form spec'' around point to be processed by +SWANK::PARSE-FORM-SPEC. It is similiar to +SLIME-INCOMPLETE-SEXP-AT-POINT but looks further back than just +one sexp to find out the context." + (multiple-value-bind (operators arg-indices points) + (slime-enclosing-form-specs) + (if (null operators) + "" + (let ((op (first operators))) + (destructure-case (slime-ensure-list op) + ((:declaration declspec) op) + ((:type-specifier typespec) op) + (t (slime-ensure-list + (save-excursion (goto-char (first points)) + (slime-parse-sexp-at-point + (1+ (first arg-indices))))))))))) + +;; XXX: unused function +(defun slime-cl-symbol-external-ref-p (symbol) + "Does SYMBOL refer to an external symbol? +FOO:BAR is an external reference. +FOO::BAR is not, and nor is BAR." + (let ((name (if (stringp symbol) symbol (symbol-name symbol)))) + (and (string-match ":" name) + (not (string-match "::" name))))) + +(defun slime-cl-symbol-name (symbol) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match ":\([^:]*\)$" n) + (let ((symbol-part (match-string 1 n))) + (if (string-match "^|\(.*\)|$" symbol-part) + (match-string 1 symbol-part) + symbol-part)) + n))) + +(defun slime-cl-symbol-package (symbol &optional default) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match "^\([^:]*\):" n) + (match-string 1 n) + default))) + +;; XXX: unused function +(defun slime-qualify-cl-symbol (symbol-or-name) + "Like `slime-qualify-cl-symbol-name', but interns the result." + (intern (slime-qualify-cl-symbol-name symbol-or-name))) + +(defun slime-qualify-cl-symbol-name (symbol-or-name) + "Return a package-qualified symbol-name that indicates the CL symbol +SYMBOL. If SYMBOL doesn't already have a package prefix the current +package is used." + (let ((s (if (stringp symbol-or-name) + symbol-or-name + (symbol-name symbol-or-name)))) + (if (slime-cl-symbol-package s) + s + (format "%s::%s" + (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))))) + + +(defun slime-parse-sexp-at-point (&optional n skip-blanks-p) + "Return the sexp at point as a string, otherwise nil. +If N is given and greater than 1, a list of all such sexps +following the sexp at point is returned. (If there are not +as many sexps as N, a list with < N sexps is returned.) + +If SKIP-BLANKS-P is true, leading whitespaces &c are skipped. +" + (interactive "p") (or n (setq n 1)) + (flet ((sexp-at-point (first-choice) + (let ((string (if (eq first-choice :symbol-first) + (or (slime-symbol-name-at-point) + (thing-at-point 'sexp)) + (or (thing-at-point 'sexp) + (slime-symbol-name-at-point))))) + (if string (substring-no-properties string) nil)))) + ;; `thing-at-point' depends upon the current syntax table; otherwise + ;; keywords like `:foo' are not recognized as sexps. (This function + ;; may be called from temporary buffers etc.) + (with-syntax-table lisp-mode-syntax-table + (save-excursion + (when skip-blanks-p ; e.g. `( foo bat)' where point is after ?(. + (slime-forward-blanks)) + (let ((result nil)) + (dotimes (i n) + ;; `foo(bar baz)' where point is at ?( or ?). + (if (and (char-after) (member (char-syntax (char-after)) '(?( ?) ?'))) + (push (sexp-at-point :sexp-first) result) + (push (sexp-at-point :symbol-first) result)) + (ignore-errors (forward-sexp) (slime-forward-blanks)) + (save-excursion + (unless (slime-point-moves-p (ignore-errors (forward-sexp))) + (return)))) + (if (slime-length= result 1) + (first result) + (nreverse result))))))) + +(defun slime-incomplete-sexp-at-point (&optional n) + (interactive "p") (or n (setq n 1)) + (buffer-substring-no-properties (save-excursion (backward-up-list n) (point)) + (point))) + + +(defun slime-parse-extended-operator-name (user-point forms indices points) + "Assume that point is directly at the operator that should be parsed. +USER-POINT is the value of `point' where the user was looking at. +OPS, INDICES and POINTS are updated to reflect the new values after +parsing, and are then returned back as multiple values." + ;; OPS, INDICES and POINTS are like the finally returned values of + ;; SLIME-ENCLOSING-FORM-SPECS except that they're in reversed order, + ;; i.e. the leftmost (that is the latest) operator comes + ;; first. + (save-excursion + (ignore-errors + (let* ((current-op (first (first forms))) + (op-name (upcase (slime-cl-symbol-name current-op))) + (assoc (assoc op-name slime-extended-operator-name-parser-alist)) + (entry (cdr assoc)) + (parser (if (and entry (listp entry)) + (apply (first entry) (rest entry)) + entry))) + (ignore-errors + (forward-char (1+ (length current-op))) + (slime-forward-blanks)) + (when parser + (multiple-value-setq (forms indices points) + (funcall parser op-name user-point forms indices points)))))) + (values forms indices points)) + + +(defvar slime-extended-operator-name-parser-alist + '(("MAKE-INSTANCE" . (slime-make-extended-operator-parser/look-ahead 1)) + ("MAKE-CONDITION" . (slime-make-extended-operator-parser/look-ahead 1)) + ("ERROR" . (slime-make-extended-operator-parser/look-ahead 1)) + ("SIGNAL" . (slime-make-extended-operator-parser/look-ahead 1)) + ("WARN" . (slime-make-extended-operator-parser/look-ahead 1)) + ("CERROR" . (slime-make-extended-operator-parser/look-ahead 2)) + ("CHANGE-CLASS" . (slime-make-extended-operator-parser/look-ahead 2)) + ("DEFMETHOD" . (slime-make-extended-operator-parser/look-ahead 1)) + ("APPLY" . (slime-make-extended-operator-parser/look-ahead 1)) + ("DECLARE" . slime-parse-extended-operator/declare) + ("DECLAIM" . slime-parse-extended-operator/declare) + ("PROCLAIM" . slime-parse-extended-operator/declare))) + +(defun slime-make-extended-operator-parser/look-ahead (steps) + "Returns a parser that parses the current operator at point +plus STEPS-many additional sexps on the right side of the +operator." + (lexical-let ((n steps)) + #'(lambda (name user-point current-forms current-indices current-points) + (let ((old-forms (rest current-forms))) + (let* ((args (slime-ensure-list (slime-parse-sexp-at-point n))) + (arg-specs (mapcar #'slime-make-form-spec-from-string args))) + (setq current-forms (cons `(,name ,@arg-specs) old-forms)))) + (values current-forms current-indices current-points) + ))) + +(defun slime-parse-extended-operator/declare + (name user-point current-forms current-indices current-points) + (when (string= (thing-at-point 'char) "(") + (let ((orig-point (point))) + (goto-char user-point) + (slime-end-of-symbol) + ;; Head of CURRENT-FORMS is "declare" at this point, but we're + ;; interested in what comes next. + (let* ((decl-ops (rest current-forms)) + (decl-indices (rest current-indices)) + (decl-points (rest current-points)) + (decl-pos (1- (first decl-points))) + (nesting (slime-nesting-until-point decl-pos)) + (declspec-str (concat (slime-incomplete-sexp-at-point nesting) + (make-string nesting ?))))) + (save-match-data ; `(declare ((foo ...))' or `(declare (type (foo ...)))' ? + (if (or (eql 0 (string-match "\s-*(\((\(\sw\|\s_\|\s-\)*)\))$" + declspec-str)) + (eql 0 (string-match "\s-*(type\s-*\((\(\sw\|\s_\|\s-\)*)\))$" + declspec-str))) + (let* ((typespec-str (match-string 1 declspec-str)) + (typespec (slime-make-form-spec-from-string typespec-str))) + (setq current-forms (list `(:type-specifier ,typespec))) + (setq current-indices (list (second decl-indices))) + (setq current-points (list (second decl-points)))) + (let ((declspec (slime-make-form-spec-from-string declspec-str))) + (setq current-forms (list `(,name) `(:declaration ,declspec))) + (setq current-indices (list (first current-indices) + (first decl-indices))) + (setq current-points (list (first current-points) + (first decl-points))))))))) + (values current-forms current-indices current-points)) + +(defun slime-nesting-until-point (target-point) + "Returns the nesting level between current point and TARGET-POINT. +If TARGET-POINT could not be reached, 0 is returned. (As a result +TARGET-POINT should always be placed just before a `?('.)" + (save-excursion + (let ((nesting 0)) + (while (> (point) target-point) + (backward-up-list) + (incf nesting)) + (if (= (point) target-point) + nesting + 0)))) + +(defun slime-make-form-spec-from-string (string &optional strip-operator-p) + "If STRIP-OPERATOR-P is T and STRING is the string +representation of a form, the string representation of this form +is stripped from the form. This can be important to avoid mutual +recursion between this function, `slime-enclosing-form-specs' and +`slime-parse-extended-operator-name'. + +Examples: + + "(foo (bar 1 (baz :quux)) 'toto)" + + => ("foo" ("bar" "1" ("baz" ":quux")) "'toto") +" + (cond ((slime-length= string 0) "") + ((equal string "()") '()) + (t + (with-temp-buffer + ;; Do NEVER ever try to activate `lisp-mode' here with + ;; `slime-use-autodoc-mode' enabled, as this function is used + ;; to compute the current autodoc itself. + (erase-buffer) + (insert string) + (when strip-operator-p ; `(OP arg1 arg2 ...)' ==> `(arg1 arg2 ...)' + (goto-char (point-min)) + (when (string= (thing-at-point 'char) "(") + (ignore-errors (forward-char 1) + (forward-sexp) + (slime-forward-blanks)) + (delete-region (point-min) (point)) + (insert "("))) + (goto-char (1- (point-max))) ; `(OP arg1 ... argN|)' + (multiple-value-bind (forms indices points) + (slime-enclosing-form-specs 1) + (if (null forms) + string + (let ((n (first (last indices)))) + (goto-char (1+ (point-min))) ; `(|OP arg1 ... argN)' + (mapcar #'(lambda (s) + (assert (not (equal s string))) ; trap against + (slime-make-form-spec-from-string s)) ; endless recursion. + (slime-ensure-list + (slime-parse-sexp-at-point (1+ n) t)))))))))) + + +(defun slime-enclosing-form-specs (&optional max-levels) + "Return the list of ``raw form specs'' of all the forms +containing point from right to left. + +As a secondary value, return a list of indices: Each index tells +for each corresponding form spec in what argument position the +user's point is. + +As tertiary value, return the positions of the operators that are +contained in the returned form specs. + +When MAX-LEVELS is non-nil, go up at most this many levels of +parens. + +(See SWANK::PARSE-FORM-SPEC for more information about what +exactly constitutes a ``raw form specs'') + +Examples: + + A return value like the following + + (values (("quux") ("bar") ("foo")) (3 2 1) (p1 p2 p3)) + + can be interpreted as follows: + + The user point is located in the 3rd argument position of a + form with the operator name "quux" (which starts at P1.) + + This form is located in the 2nd argument position of a form + with the operator name "bar" (which starts at P2.) + + This form again is in the 1st argument position of a form + with the operator name "foo" (which itself begins at P3.) + + For instance, the corresponding buffer content could have looked + like `(foo (bar arg1 (quux 1 2 |' where `|' denotes point. +" + (let ((level 1) + (parse-sexp-lookup-properties nil) + (initial-point (point)) + (result '()) (arg-indices '()) (points '())) + ;; The expensive lookup of syntax-class text properties is only + ;; used for interactive balancing of #<...> in presentations; we + ;; do not need them in navigating through the nested lists. + ;; This speeds up this function significantly. + (ignore-errors + (save-excursion + ;; Make sure we get the whole thing at point. + (if (not (slime-inside-string-p)) + (slime-end-of-symbol) + (slime-beginning-of-string) + (forward-sexp)) + (save-restriction + ;; Don't parse more than 20000 characters before point, so we don't spend + ;; too much time. + (narrow-to-region (max (point-min) (- (point) 20000)) (point-max)) + (narrow-to-region (save-excursion (beginning-of-defun) (point)) + (min (1+ (point)) (point-max))) + (while (or (not max-levels) + (<= level max-levels)) + (let ((arg-index 0)) + ;; Move to the beginning of the current sexp if not already there. + (if (or (and (char-after) + (member (char-syntax (char-after)) '(?( ?'))) + (member (char-syntax (char-before)) '(?\ ?>))) + (incf arg-index)) + (ignore-errors (backward-sexp 1)) + (while (and (< arg-index 64) + (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 + (save-restriction + (widen) ; to allow looking-ahead/back in extended parsing. + (multiple-value-bind (new-result new-indices new-points) + (slime-parse-extended-operator-name initial-point + (cons `(,name) result) ; minimal form spec + (cons arg-index arg-indices) + (cons (point) points)) + (setq result new-result) + (setq arg-indices new-indices) + (setq points new-points)))) + (t + (push nil result) + (push arg-index arg-indices) + (push (point) points)))) + (backward-up-list 1))))))) + (values + (nreverse result) + (nreverse arg-indices) + (nreverse points)))) + + +(defun slime-ensure-list (thing) + (if (listp thing) thing (list thing))) + +(defun slime-inside-string-p () + (let* ((toplevel-begin (save-excursion (beginning-of-defun) (point))) + (parse-result (parse-partial-sexp toplevel-begin (point))) + (inside-string-p (nth 3 parse-result)) + (string-start-pos (nth 8 parse-result))) + (and inside-string-p string-start-pos))) + +(defun slime-beginning-of-string () + (let ((string-start-pos (slime-inside-string-p))) + (if string-start-pos + (goto-char string-start-pos) + (error "We're not within a string")))) + +(provide 'slime-parse) +
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-presentation-streams.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-presentation-streams.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-presentation-streams.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,29 @@ +;;; swank-presentation-streams.el --- Streams that allow attaching object identities +;;; to portions of output +;;; +;;; Authors: Alan Ruttenberg alanr-l@mumble.net +;;; Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de +;;; Helmut Eller heller@common-lisp.net +;;; +;;; License: GNU GPL (same license as Emacs) +;;; +;;; Installation +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-presentation-streams))) +;; + + +;;; Initialization + +(require 'slime-presentations) + +(add-hook 'slime-connected-hook 'slime-install-presentation-streams) + +(defun slime-install-presentation-streams () + (slime-eval-async '(swank:swank-require :swank-presentation-streams))) + +(provide 'slime-presentation-streams) +
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,649 @@ +;;; swank-presentations.el --- imitat LispM' presentations +;;; +;;; Authors: Alan Ruttenberg alanr-l@mumble.net +;;; Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de +;;; +;;; License: GNU GPL (same license as Emacs) +;;; +;;; Installation +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-presentations))) +;; + +(defface slime-repl-output-mouseover-face + (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) + +(defface slime-repl-inputed-output-face + '((((class color) (background light)) (:foreground "Red")) + (((class color) (background dark)) (:foreground "Red")) + (t (:slant italic))) + "Face for the result of an evaluation in the SLIME REPL." + :group 'slime-repl) + +;; FIXME: This conditional is not right - just used because the code +;; here does not work in XEmacs. +(when (boundp 'text-property-default-nonsticky) + (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky + :test 'equal) + (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky + :test 'equal)) + +(make-variable-buffer-local + (defvar slime-presentation-start-to-point (make-hash-table))) + +(defun slime-mark-presentation-start (id &optional target) + "Mark the beginning of a presentation with the given ID. +TARGET can be nil (regular process output) or :repl-result." + (setf (gethash id slime-presentation-start-to-point) + ;; We use markers because text can also be inserted before this presentation. + ;; (Output arrives while we are writing presentations within REPL results.) + (copy-marker (slime-output-target-marker target) nil))) + +(defun slime-mark-presentation-start-handler (process string) + (if (and string (string-match "<\([-0-9]+\)" string)) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) + (slime-mark-presentation-start id)))) + +(defun slime-mark-presentation-end (id &optional target) + "Mark the end of a presentation with the given ID. +TARGET can be nil (regular process output) or :repl-result." + (let ((start (gethash id slime-presentation-start-to-point))) + (remhash id slime-presentation-start-to-point) + (when start + (let* ((marker (slime-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (with-current-buffer buffer + (let ((end (marker-position marker))) + (slime-add-presentation-properties start end + id nil))))))) + +(defun slime-mark-presentation-end-handler (process string) + (if (and string (string-match ">\([-0-9]+\)" string)) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) + (slime-mark-presentation-end id)))) + +(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 &optional rectangle) + "Insert STRING in current buffer and mark it as a presentation +corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line +strings to line up below the current point." + (flet ((insert-it () + (if rectangle + (slime-insert-indented string) + (insert string)))) + (let ((start (point))) + (insert-it) + (slime-add-presentation-properties start (point) output-id t)))) + +(defun slime-presentation-whole-p (presentation start end &optional object) + (let ((object (or object (current-buffer)))) + (string= (etypecase object + (buffer (with-current-buffer object + (buffer-substring-no-properties start end))) + (string (substring-no-properties object start end))) + (slime-presentation-text presentation)))) + +(defun slime-presentations-around-point (point &optional object) + (let ((object (or object (current-buffer)))) + (loop for (key value . rest) on (text-properties-at point object) by 'cddr + when (slime-presentation-p key) + collect key))) + +(defun slime-presentation-start-p (tag) + (memq tag '(:start :start-and-end))) + +(defun slime-presentation-stop-p (tag) + (memq tag '(:end :start-and-end))) + +(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@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") + (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-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p) + 'slime-open-inspector)))) + +(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-copy-presentation-at-mouse-to-point (event) + (interactive "e") + (multiple-value-bind (presentation start end buffer) + (slime-presentation-around-click event) + (let ((presentation-text + (with-current-buffer buffer + (buffer-substring start end)))) + (when (not (string-match "\s-" + (buffer-substring (1- (point)) (point)))) + (insert " ")) + (insert presentation-text) + (slime-after-change-function (point) (point)) + (when (and (not (eolp)) (not (looking-at "\s-"))) + (insert " "))))) + +(defun slime-copy-presentation-at-mouse-to-kill-ring (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)))) + (kill-new presentation-text)))) + +(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 buffer from to choice-to-lambda) + "Return a menu for `presentation' at `from'--`to' in `buffer', suitable for `x-popup-menu'." + (let* ((what (slime-presentation-id presentation)) + (choices (with-current-buffer buffer + (slime-eval + `(swank::menu-choices-for-presentation-id ',what))))) + (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 + `(,(format "Presentation %s" what) + ("" + ("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse)) + ("Describe" . ,(savel 'slime-describe-presentation-at-mouse)) + ("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse)) + ("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse)) + ("Copy to kill ring" . ,(savel 'slime-copy-presentation-at-mouse-to-kill-ring)) + ,@(unless buffer-read-only + `(("Copy to point" . ,(savel 'slime-copy-presentation-at-mouse-to-point)))) + ,@(let ((nchoice 0)) + (mapcar + (lambda (choice) + (incf nchoice) + (cons choice + (savel `(lambda () + (interactive) + (slime-eval + '(swank::execute-menu-choice-for-presentation-id + ',what ,nchoice ,(nth (1- nchoice) choices))))))) + choices))))) + (symbol ; not-present + (with-current-buffer buffer + (slime-remove-presentation-properties from to presentation)) + (sit-for 0) ; allow redisplay + `("Object no longer recorded" + ("sorry" . ,(if (featurep 'xemacs) nil '(nil))))))))) + +(defun slime-presentation-menu (event) + (interactive "e") + (let* ((point (if (featurep 'xemacs) (event-point event) + (posn-point (event-end event)))) + (window (if (featurep 'xemacs) (event-window event) (caadr event))) + (buffer (window-buffer window)) + (choice-to-lambda (make-hash-table))) + (multiple-value-bind (presentation from to) + (with-current-buffer buffer + (slime-presentation-around-point point)) + (unless presentation + (error "No presentation at event position")) + (let ((menu (slime-menu-choices-for-presentation + presentation buffer from to choice-to-lambda))) + (let ((choice (x-popup-menu event menu))) + (when choice + (call-interactively (gethash choice choice-to-lambda)))))))) + +(defun slime-presentation-expression (presentation) + "Return a string that contains a CL s-expression accessing +the presented object." + (let ((id (slime-presentation-id presentation))) + (etypecase id + (number + ;; Make sure it works even if *read-base* is not 10. + (format "(swank: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 + (multiple-value-bind (presentation start-pos end-pos whole-p) + (slime-presentation-around-point pos str-props) + (if (not presentation) + str-no-props + (concat (substring str-no-props 0 pos) + ;; Eval in the reader so that we play nice with quote. + ;; -luke (19/May/2005) + "#." (slime-presentation-expression presentation) + (slime-reify-old-output (substring str-props end-pos) + (substring str-no-props end-pos)))))))) + + + +(defun slime-repl-grab-old-output (replace) + "Resend the old REPL output at point. +If replace it non-nil the current input is replaced with the old +output; otherwise the new input is appended." + (multiple-value-bind (presentation beg end) + (slime-presentation-around-or-before-point (point)) + (let ((old-output (buffer-substring beg end))) ;;keep properties + ;; Append the old input or replace the current input + (cond (replace (goto-char slime-repl-input-start-mark)) + (t (goto-char slime-repl-input-end-mark) + (unless (eq (char-before) ?\ ) + (insert " ")))) + (delete-region (point) slime-repl-input-end-mark) + (let ((inhibit-read-only t)) + (insert old-output))))) + + +;;; hook functions (hard to isolate stuff) + +(defun slime-dispatch-presentation-event (event) + (destructure-case event + ((:presentation-start id &optional target) + (slime-mark-presentation-start id target) + t) + ((:presentation-end id &optional target) + (slime-mark-presentation-end id target) + t) + (t nil))) + +(defun slime-presentation-write (string &optional target) + (case target + ((nil) ; Regular process output + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (slime-propertize-region '(face slime-repl-output-face + rear-nonsticky (face)) + (insert string)) + (set-marker slime-output-end (point)) + (when (and (= (point) slime-repl-prompt-start-mark) + (not (bolp))) + (insert "\n") + (set-marker slime-output-end (1- (point)))) + (if (< slime-repl-input-start-mark (point)) + (set-marker slime-repl-input-start-mark + (point)))))) + (:repl-result + (with-current-buffer (slime-output-buffer) + (let ((marker (slime-output-target-marker target))) + (goto-char marker) + (let ((result-start (point))) + (slime-propertize-region `(face slime-repl-result-face + rear-nonsticky (face)) + (insert string)) + ;; Move the input-start marker after the REPL result. + (set-marker marker (point)))))) + (t + (let* ((marker (slime-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (when buffer + (with-current-buffer buffer + (save-excursion + ;; Insert STRING at MARKER, then move MARKER behind + ;; the insertion. + (goto-char marker) + (insert-before-markers string) + (set-marker marker (point))))))))) + +(defun slime-presentation-current-input (&optional until-point-p) + "Return the current input as string. +The input is the region from after the last prompt to the end of +buffer. Presentations of old results are expanded into code." + (slime-buffer-substring-with-reified-output slime-repl-input-start-mark + (if (and until-point-p + (<= (point) slime-repl-input-end-mark)) + (point) + slime-repl-input-end-mark))) +(defun slime-presentation-on-return-pressed () + (cond ((and (car (slime-presentation-around-or-before-point (point))) + (< (point) slime-repl-input-start-mark)) + (slime-repl-grab-old-output end-of-input) + (slime-repl-recenter-if-needed) + t) + (t nil))) + +(defun slime-presentation-on-stream-open (stream) + (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))) + +(defun slime-clear-presentations () + (slime-eval-async `(swank:clear-repl-results))) + +;;; Initialization + +(defun slime-presentations-init () + (add-hook 'slime-repl-mode-hook + (lambda () + ;; Respect the syntax text properties of presentation. + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (add-local-hook 'after-change-functions + 'slime-after-change-function))) + (add-hook 'slime-event-hooks 'slime-dispatch-presentation-event) + (setq slime-write-string-function 'slime-presentation-write) + (add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed) + (add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input) + (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open) + (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations) + (add-hook 'slime-connected-hook 'slime-install-presentations)) + +(defun slime-install-presentations () + (slime-eval-async '(swank:swank-require :swank-presentations))) + +(slime-presentations-init) + +(provide 'slime-presentations)
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-references.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-references.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-references.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,135 @@ +;;; slime-references.el --- Clickable references to documentation (SBCL only) +;; +;; Authors: Christophe Rhodes csr21@cantab.net +;; Luke Gorrie luke@bluetail.com +;; +;; License: GNU GPL (same license as Emacs) +;; +;;; + +(defcustom slime-sbcl-manual-root "http://www.sbcl.org/manual/" + "*The base URL of the SBCL manual, for documentation lookup." + :type 'string + :group 'slime-mode) + +(defface sldb-reference-face + (list (list t '(:underline t))) + "Face for references." + :group 'slime-debugger) + +(defun slime-note.references (note) + (plist-get note :references)) + +(defun slime-tree-print-with-references (tree) + ;; for SBCL-style references + (slime-tree-default-printer tree) + (when-let (note (plist-get (slime-tree.plist tree) 'note)) + (when-let (references (slime-note.references note)) + (terpri (current-buffer)) + (princ "See also:" (current-buffer)) + (terpri (current-buffer)) + (slime-tree-insert-references references)))) + +(defun slime-tree-insert-references (references) + "Insert documentation references from a condition. +See SWANK-BACKEND:CONDITION-REFERENCES for the datatype." + (loop for refs on references + for ref = (car refs) + do + (destructuring-bind (where type what) ref + ;; FIXME: this is poorly factored, and shares some code and + ;; data with sldb that it shouldn't: notably + ;; sldb-reference-face. Probably the names of + ;; sldb-reference-foo should be altered to be not sldb + ;; specific. + (insert " " (sldb-format-reference-source where) ", ") + (slime-insert-propertized (sldb-reference-properties ref) + (sldb-format-reference-node what)) + (insert (format " [%s]" type)) + (when (cdr refs) + (terpri (current-buffer)))))) + + +;;;;; SLDB references (rather SBCL specific) + +(defun sldb-insert-references (references) + "Insert documentation references from a condition. +See SWANK-BACKEND:CONDITION-REFERENCES for the datatype." + (dolist (ref references) + (destructuring-bind (where type what) ref + (insert "\n" (sldb-format-reference-source where) ", ") + (slime-insert-propertized (sldb-reference-properties ref) + (sldb-format-reference-node what)) + (insert (format " [%s]" type))))) + +(defun sldb-reference-properties (reference) + "Return the properties for a reference. +Only add clickability to properties we actually know how to lookup." + (destructuring-bind (where type what) reference + (if (or (and (eq where :sbcl) (eq type :node)) + (and (eq where :ansi-cl) + (memq type '(:function :special-operator :macro + :section :glossary :issue)))) + `(sldb-default-action + sldb-lookup-reference + ;; FIXME: this is a hack! slime-compiler-notes and sldb are a + ;; little too intimately entwined. + slime-compiler-notes-default-action sldb-lookup-reference + sldb-reference ,reference + face sldb-reference-face + mouse-face highlight)))) + +(defun sldb-format-reference-source (where) + (case where + (:amop "The Art of the Metaobject Protocol") + (:ansi-cl "Common Lisp Hyperspec") + (:sbcl "SBCL Manual") + (t (format "%S" where)))) + +(defun sldb-format-reference-node (what) + (if (listp what) + (mapconcat #'prin1-to-string what ".") + what)) + +(defun sldb-lookup-reference () + "Browse the documentation reference at point." + (destructuring-bind (where type what) + (get-text-property (point) 'sldb-reference) + (case where + (:ansi-cl + (case type + (:section + (browse-url (funcall common-lisp-hyperspec-section-fun what))) + (:glossary + (browse-url (funcall common-lisp-glossary-fun what))) + (:issue + (browse-url (funcall 'common-lisp-issuex what))) + (t + (hyperspec-lookup what)))) + (t + (let ((url (format "%s%s.html" slime-sbcl-manual-root + (subst-char-in-string ?\ ?- what)))) + (browse-url url)))))) + +(defun sldb-maybe-insert-references (extra) + (destructure-case extra + ((:references references) + (when references + (insert "\nSee also:") + (slime-with-rigid-indentation 2 + (sldb-insert-references references))) + t) + (t nil))) + + +;;; Initialization + +(defun slime-references-init () + (setq slime-tree-printer 'slime-tree-print-with-references) + (add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)) + +(defun slime-references-unload () + (setq slime-tree-printer 'slime-tree-default-printer) + (remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)) + +(provide 'slime-references)
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-scratch.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-scratch.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-scratch.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,48 @@ +;;; slime-scratch.el --- imitate Emacs' *scratch* buffer +;; +;; Author: Helmut Eller heller@common-lisp.net +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path ".../slime/contrib") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-scratch))) +;; + + +;;; Code + +(defvar slime-scratch-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map lisp-mode-map) + map)) + +(defun slime-scratch () + (interactive) + (slime-switch-to-scratch-buffer)) + +(defun slime-switch-to-scratch-buffer () + (set-buffer (slime-scratch-buffer)) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t))) + +(defun slime-scratch-buffer () + "Return the scratch buffer, create it if necessary." + (or (get-buffer "*slime-scratch*") + (with-current-buffer (get-buffer-create "*slime-scratch*") + (lisp-mode) + (use-local-map slime-scratch-mode-map) + (slime-mode t) + (current-buffer)))) + +(slime-define-keys slime-scratch-mode-map + ("\C-j" 'slime-eval-print-last-expression)) + +(defun slime-scratch-init () + (def-slime-selector-method ?s + "*slime-scratch* buffer." + (slime-scratch-buffer))) + +(provide 'slime-scratch) \ No newline at end of file
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-tramp.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-tramp.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-tramp.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,55 @@ +;;; slime-tramp.el --- Filename translations for tramp +;; +;; Authors: Marco Baringer mb@bese.it +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path ".../slime/contrib") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-tramp))) +;; + +(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))))) + +(provide 'slime-tramp) \ No newline at end of file
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,91 @@ +;;; slime-typeout-frame.el --- display some message in a dedicated frame +;; +;; Author: Luke Gorrie luke@synap.se +;; License: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add something like this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-typeout-frame))) +;; + + +;;;; Typeout frame + +;; When a "typeout frame" exists it is used to display certain +;; messages instead of the echo area or pop-up windows. + +(defvar slime-typeout-window nil + "The current typeout window.") + +(defvar slime-typeout-frame-properties + '((height . 10) (minibuffer . nil)) + "The typeout frame properties (passed to `make-frame').") + +(defun slime-typeout-active-p () + (and slime-typeout-window + (window-live-p slime-typeout-window))) + +(defun slime-typeout-message-aux (format-string &rest format-args) + (slime-ensure-typeout-frame) + (with-current-buffer (window-buffer slime-typeout-window) + (let ((msg (apply #'format format-string format-args))) + (unless (string= msg "") + (erase-buffer) + (insert msg))))) + +(defun slime-typeout-message (format-string &rest format-args) + (apply #'slime-typeout-message-aux format-string format-args) + ;; Disable the timer for autodoc temporarily, as it would overwrite + ;; the current typeout message otherwise. + (when (and (featurep 'slime-autodoc) slime-autodoc-mode) + (slime-autodoc-stop-timer) + (add-hook 'pre-command-hook #'slime-autodoc-start-timer))) + +(defun slime-make-typeout-frame () + "Create a frame for displaying messages (e.g. arglists)." + (interactive) + (let ((frame (make-frame slime-typeout-frame-properties))) + (save-selected-window + (select-window (frame-selected-window frame)) + (switch-to-buffer "*SLIME-Typeout*") + (setq slime-typeout-window (selected-window))))) + +(defun slime-ensure-typeout-frame () + "Create the typeout frame unless it already exists." + (interactive) + (unless (slime-typeout-active-p) + (slime-make-typeout-frame))) + +(defun slime-typeout-autodoc-message (doc) + ;; No need for refreshing per `slime-autodoc-pre-command-refresh-echo-area'. + (setq slime-autodoc-last-message "") + (slime-typeout-message-aux "%s" doc)) + + +;;; Initialization + +(defvar slime-typeout-frame-unbind-stack ()) + +(defun slime-typeout-frame-init () + (add-hook 'slime-connected-hook 'slime-ensure-typeout-frame) + (loop for (var value) in + '((slime-message-function slime-typeout-message) + (slime-background-message-function slime-typeout-message) + (slime-autodoc-message-function slime-typeout-autodoc-message)) + do (slime-typeout-frame-init-var var value))) + +(defun slime-typeout-frame-init-var (var value) + (push (list var (if (boundp var) (symbol-value var) 'slime-unbound)) + slime-typeout-frame-unbind-stack) + (set var value)) + +(defun slime-typeout-frame-unload () + (remove-hook 'slime-connected-hook 'slime-ensure-typeout-frame) + (loop for (var value) in slime-typeout-frame-unbind-stack + do (cond ((eq var 'slime-unbound) (makunbound var)) + (t (set var value))))) + +(provide 'slime-typeout-frame)
Added: branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,104 @@ +;;; slime-xref-browser.el --- xref browsing with tree-widget +;; +;; Author: Rui Patroc�nio rui.patrocinio@netvisao.pt +;; Licencse: GNU GPL (same license as Emacs) +;; +;;; Installation: +;; +;; Add this to your .emacs: +;; +;; (add-to-list 'load-path "<directory-of-this-file>") +;; (add-hook 'slime-load-hook (lambda () (require 'slime-xref-browser))) +;; + + +;;;; classes browser + +(defun slime-expand-class-node (widget) + (or (widget-get widget :args) + (let ((name (widget-get widget :tag))) + (loop for kid in (slime-eval `(swank:mop :subclasses ,name)) + collect `(tree-widget :tag ,kid + :dynargs slime-expand-class-node + :has-children t))))) + +(defun slime-browse-classes (name) + "Read the name of a class and show its subclasses." + (interactive (list (slime-read-symbol-name "Class Name: "))) + (slime-call-with-browser-setup + "*slime class browser*" (slime-current-package) "Class Browser" + (lambda () + (widget-create 'tree-widget :tag name + :dynargs 'slime-expand-class-node + :has-echildren t)))) + +(defvar slime-browser-map nil + "Keymap for tree widget browsers") + +(require 'tree-widget) +(unless slime-browser-map + (setq slime-browser-map (make-sparse-keymap)) + (set-keymap-parent slime-browser-map widget-keymap) + (define-key slime-browser-map "q" 'bury-buffer)) + +(defun slime-call-with-browser-setup (buffer package title fn) + (switch-to-buffer buffer) + (kill-all-local-variables) + (setq slime-buffer-package package) + (let ((inhibit-read-only t)) (erase-buffer)) + (widget-insert title "\n\n") + (save-excursion + (funcall fn)) + (lisp-mode-variables t) + (slime-mode t) + (use-local-map slime-browser-map) + (widget-setup)) + + +;;;; Xref browser + +(defun slime-fetch-browsable-xrefs (type name) + "Return a list ((LABEL DSPEC)). +LABEL is just a string for display purposes. +DSPEC can be used to expand the node." + (let ((xrefs '())) + (loop for (_file . specs) in (slime-eval `(swank:xref ,type ,name)) do + (loop for (dspec . _location) in specs do + (let ((exp (ignore-errors (read (downcase dspec))))) + (cond ((and (consp exp) (eq 'flet (car exp))) + ;; we can't expand FLET references so they're useless + ) + ((and (consp exp) (eq 'method (car exp))) + ;; this isn't quite right, but good enough for now + (push (list dspec (string (second exp))) xrefs)) + (t + (push (list dspec dspec) xrefs)))))) + xrefs)) + +(defun slime-expand-xrefs (widget) + (or (widget-get widget :args) + (let* ((type (widget-get widget :xref-type)) + (dspec (widget-get widget :xref-dspec)) + (xrefs (slime-fetch-browsable-xrefs type dspec))) + (loop for (label dspec) in xrefs + collect `(tree-widget :tag ,label + :xref-type ,type + :xref-dspec ,dspec + :dynargs slime-expand-xrefs + :has-children t))))) + +(defun slime-browse-xrefs (name type) + "Show the xref graph of a function in a tree widget." + (interactive + (list (slime-read-from-minibuffer "Name: " + (slime-symbol-name-at-point)) + (read (completing-read "Type: " (slime-bogus-completion-alist + '(":callers" ":callees" ":calls")) + nil t ":")))) + (slime-call-with-browser-setup + "*slime xref browser*" (slime-current-package) "Xref Browser" + (lambda () + (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name + :dynargs 'slime-expand-xrefs :has-echildren t)))) + +(provide 'slime-xref-browser) \ No newline at end of file
Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,1217 @@ +;;; swank-arglists.lisp --- arglist related code ?? +;; +;; Authors: Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de +;; Tobias C. Rittweiler tcr@freebits.de +;; and others +;; +;; License: Public Domain +;; + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-c-p-c)) + +(defun valid-operator-symbol-p (symbol) + "Is SYMBOL the name of a function, a macro, or a special-operator?" + (or (fboundp symbol) + (macro-function symbol) + (special-operator-p symbol) + (eq symbol 'declare))) + +(defun valid-operator-name-p (string) + "Is STRING the name of a function, macro, or special-operator?" + (let ((symbol (parse-symbol string))) + (valid-operator-symbol-p symbol))) + +(defslimefun arglist-for-echo-area (raw-specs &key arg-indices + print-right-margin print-lines) + "Return the arglist for the first valid ``form spec'' in +RAW-SPECS. A ``form spec'' is a superset of functions, macros, +special-ops, declarations and type specifiers. + +For more information about the format of ``raw form specs'' and +``form specs'', please see PARSE-FORM-SPEC." + (handler-case + (with-buffer-syntax () + (multiple-value-bind (form-spec position newly-interned-symbols) + (parse-first-valid-form-spec raw-specs #'read-conversatively-for-autodoc) + (unwind-protect + (when form-spec + (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) + (unless (eql arglist :not-available) + (multiple-value-bind (type operator arguments) + (split-form-spec form-spec) + (declare (ignore arguments)) + (multiple-value-bind (stringified-arglist) + (decoded-arglist-to-string + arglist + :operator operator + :print-right-margin print-right-margin + :print-lines print-lines + :highlight (let ((index (nth position arg-indices))) + ;; don't highlight the operator + (and index (not (zerop index)) index))) + ;; Post formatting: + (case type + (:type-specifier (format nil "[Typespec] ~A" stringified-arglist)) + (:declaration + (locally (declare (special *arglist-pprint-bindings*)) + (with-bindings *arglist-pprint-bindings* + (let ((op (%find-declaration-operator raw-specs position))) + (if op + (format nil "(~A ~A)" op stringified-arglist) + (format nil "[Declaration] ~A" stringified-arglist)))))) + (t stringified-arglist))))))) + (mapc #'unintern-in-home-package newly-interned-symbols)))) + (error (cond) + (format nil "ARGLIST (error): ~A" cond)) + )) + +(defun %find-declaration-operator (raw-specs position) + (let ((op-rawspec (nth (1+ position) raw-specs))) + (first (parse-form-spec op-rawspec #'read-conversatively-for-autodoc)))) + +(defvar *arglist-dummy* (cons :dummy nil)) + +(defun read-conversatively-for-autodoc (string) + "Tries to find the symbol that's represented by STRING. + +If it can't, this either means that STRING does not represent a +symbol, or that the symbol behind STRING would have to be freshly +interned. Because this function is supposed to be called from the +automatic arglist display stuff from Slime, interning freshly +symbols is a big no-no. + +In such a case (that no symbol could be found), the object +*ARGLIST-DUMMY* is returned instead, which works as a placeholder +datum for subsequent logics to rely on." + (let* ((string (string-left-trim '(#\Space #\Tab #\Newline) string)) + (quoted? (eql (aref string 0) #'))) + (multiple-value-bind (symbol found?) + (parse-symbol (if quoted? (subseq string 1) string)) + (if found? + (if quoted? `(quote ,symbol) symbol) + *arglist-dummy*)))) + + +(defun parse-form-spec (raw-spec &optional reader) + "Takes a raw (i.e. unparsed) form spec from SLIME and returns a +proper form spec for further processing within SWANK. Returns NIL +if RAW-SPEC could not be parsed. Symbols that had to be interned +in course of the conversion, are returned as secondary return value. + +A ``raw form spec'' can be either: + + i) a list of strings representing a Common Lisp form + + ii) a list of strings as of i), but which additionally + contains other raw form specs + + iii) one of: + + a) (:declaration declspec) + + where DECLSPEC is a raw form spec. + + b) (:type-specifier typespec) + + where TYPESPEC is a raw form spec. + + +A ``form spec'' is either + + 1) a normal Common Lisp form + + 2) a Common Lisp form with a list as its CAR specifying what namespace + the operator is supposed to be interpreted in: + + a) ((:declaration decl-identifier) declarg1 declarg2 ...) + + b) ((:type-specifier typespec-op) typespec-arg1 typespec-arg2 ...) + + +Examples: + + ("defmethod") => (defmethod) + ("cl:defmethod") => (cl:defmethod) + ("defmethod" "print-object") => (defmethod print-object) + + ("foo" ("bar" ("quux")) "baz" => (foo (bar (quux)) baz) + + (:declaration "optimize" "(optimize)") => ((:declaration optimize)) + (:declaration "type" "(type string)") => ((:declaration type) string) + (:type-specifier "float" "(float)") => ((:type-specifier float)) + (:type-specifier "float" "(float 0 100)") => ((:type-specifier float) 0 100) +" + (flet ((parse-extended-spec (raw-extension extension-flag) + (when (and (stringp (first raw-extension)) ; (:DECLARATION (("a" "b" ("c")) "d")) + (nth-value 1 (parse-symbol (first raw-extension)))) + (multiple-value-bind (extension introduced-symbols) + (read-form-spec raw-extension reader) + (unless (recursively-empty-p extension) ; (:DECLARATION (())) &c. + (destructuring-bind (identifier &rest args) extension + (values `((,extension-flag ,identifier) ,@args) + introduced-symbols))))))) + (when (consp raw-spec) + (destructure-case raw-spec + ((:declaration raw-declspec) + (parse-extended-spec raw-declspec :declaration)) + ((:type-specifier raw-typespec) + (parse-extended-spec raw-typespec :type-specifier)) + (t + (when (every #'(lambda (x) (or (stringp x) (consp x))) raw-spec) + (destructuring-bind (raw-operator &rest raw-args) raw-spec + (multiple-value-bind (operator found?) (parse-symbol raw-operator) + (when (and found? (valid-operator-symbol-p operator)) + (multiple-value-bind (parsed-args introduced-symbols) + (read-form-spec raw-args reader) + (values `(,operator ,@parsed-args) introduced-symbols))))))))))) + + +(defun split-form-spec (spec) + "Returns all three relevant information a ``form spec'' +contains: the operator type, the operator, and the operands." + (destructuring-bind (operator-designator &rest arguments) spec + (multiple-value-bind (type operator) + (if (listp operator-designator) + (values (first operator-designator) (second operator-designator)) + (values :function operator-designator)) ; functions, macros, special ops + (values type operator arguments)))) ; are all fbound. + +(defun parse-first-valid-form-spec (raw-specs &optional reader) + "Returns the first parsed form spec in RAW-SPECS that can +successfully be parsed. Additionally returns that spec's position +as secondary, and all newly interned symbols as tertiary return +value." + (loop for raw-spec in raw-specs + for pos upfrom 0 + do (multiple-value-bind (spec symbols) (parse-form-spec raw-spec reader) + (when spec (return (values spec pos symbols)))))) + +(defun read-form-spec (spec &optional reader) + "Turns the ``raw form spec'' SPEC into a proper Common Lisp +form. As secondary return value, it returns all the symbols that +had to be newly interned during the conversion. + +READER is a function that takes a string, and returns two values: +the Common Lisp datum that the string represents, a flag whether +the returned datum is a symbol and has been newly interned in +some package. + +If READER is not explicitly given, the function READ-SOFTLY is +used instead." + (when spec + (with-buffer-syntax () + (call-with-ignored-reader-errors + #'(lambda () + (let ((result) (newly-interned-symbols) (ok)) + (unwind-protect + (dolist (element spec (setq ok t)) + (etypecase element + (string + (multiple-value-bind (sexp newly-interned?) + (funcall (or reader 'read-softly) element) + (push sexp result) + (when newly-interned? + (push sexp newly-interned-symbols)))) + (cons + (multiple-value-bind (read-spec interned-symbols) + (read-form-spec element) + (push read-spec result) + (setf newly-interned-symbols + (append interned-symbols + newly-interned-symbols)))))) + (unless ok + (mapc #'unintern-in-home-package newly-interned-symbols))) + (values (nreverse result) + (nreverse newly-interned-symbols)))))))) + +(defun unintern-in-home-package (symbol) + (unintern symbol (symbol-package symbol))) + +(defun read-softly (string) + "Returns two values: + + 1. the object resulting from READing STRING. + + 2. T if the object is a symbol that had to be newly interned + in some package. (This does not work for symbols in + compound forms like lists or vectors.)" + (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string) + (if found? + (values symbol nil) + (let ((sexp (read-from-string string))) + (values sexp + (when (symbolp sexp) + (prog1 t + ;; assert that PARSE-SYMBOL didn't parse incorrectly. + (assert (and (equal symbol-name (symbol-name sexp)) + (eq package (symbol-package sexp))))))))))) + + +(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 + any-p ; whether &any appeared + any-args ; list of &any arguments [*] + known-junk ; &whole, &environment + unknown-junk) ; unparsed stuff + +;;; +;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp, +;;; and is only used to describe certain arglists that cannot be +;;; described in another way. +;;; +;;; &ANY is very similiar to &KEY but while &KEY is based upon +;;; the idea of a plist (key1 value1 key2 value2), &ANY is a +;;; cross between &OPTIONAL, &KEY and *FEATURES* lists: +;;; +;;; a) (&ANY :A :B :C) means that you can provide any (non-null) +;;; set consisting of the keywords `:A', `:B', or `:C' in +;;; the arglist. E.g. (:A) or (:C :B :A). +;;; +;;; (This is not restricted to keywords only, but any self-evaluating +;;; expression is allowed.) +;;; +;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can +;;; provide any (non-null) set consisting of lists where +;;; the CAR of the list is one of `key1', `key2', or `key3'. +;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23)) +;;; +;;; +;;; For example, a) let us describe the situations of EVAL-WHEN as +;;; +;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body) +;;; +;;; and b) let us describe the optimization qualifiers that are valid +;;; in the declaration specifier `OPTIMIZE': +;;; +;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...)) +;;; + +(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 + (if (keywordp arg) + (prin1 arg) ; for &ANY args. + (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)) + (when (arglist.any-args arglist) + (print-with-space '&any) + (mapc #'print-with-space + (arglist.any-args arglist))) + (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)))))) + +(defvar *arglist-pprint-bindings* + '((*print-case* . :downcase) + (*print-pretty* . t) + (*print-circle* . nil) + (*print-readably* . nil) + (*print-level* . 10) + (*print-length* . 20) + (*print-escape* . nil))) ; no package qualifiers. + +(defun decoded-arglist-to-string (arglist + &key operator highlight (package *package*) + print-right-margin print-lines) + "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 + (with-bindings *arglist-pprint-bindings* + (let ((*package* package) + (*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." + (with-buffer-syntax () + (let ((sym (parse-symbol variable-name))) + (if (and sym (boundp sym)) + (let ((*print-pretty* nil) (*print-level* 4) + (*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))) + keyword + arg-name + default-arg) + +(defun decode-keyword-arg (arg) + "Decode a keyword item of formal argument list. +Return three values: keyword, argument name, default arg." + (cond ((symbolp arg) + (make-keyword-arg (intern (symbol-name arg) keyword-package) + arg + nil)) + ((and (consp arg) + (consp (car arg))) + (make-keyword-arg (caar 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")))) + +(defun encode-keyword-arg (arg) + (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) + (make-keyword-arg :x 'x nil))) + (assert (equalp (decode-keyword-arg '(x t)) + (make-keyword-arg :x 'x t))) + (assert (equalp (decode-keyword-arg '((:x y))) + (make-keyword-arg :x 'y nil))) + (assert (equalp (decode-keyword-arg '((:x y) t)) + (make-keyword-arg :x 'y t)))) + +(defstruct (optional-arg + (:conc-name optional-arg.) + (:constructor make-optional-arg (arg-name default-arg))) + arg-name + default-arg) + +(defun decode-optional-arg (arg) + "Decode an optional item of a formal argument list. +Return an OPTIONAL-ARG structure." + (etypecase arg + (symbol (make-optional-arg arg nil)) + (list (make-optional-arg (decode-required-arg (car arg)) + (cadr arg))))) + +(defun encode-optional-arg (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))) + +(progn + (assert (equalp (decode-optional-arg 'x) + (make-optional-arg 'x nil))) + (assert (equalp (decode-optional-arg '(x t)) + (make-optional-arg 'x t)))) + +(define-modify-macro nreversef () nreverse "Reverse the list in PLACE.") + +(defun decode-arglist (arglist) + "Parse the list ARGLIST and return an ARGLIST structure." + (let ((mode nil) + (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))) + ((and (symbolp arg) + (string= (symbol-name arg) (string '#:&ANY))) ; may be interned + (setf (arglist.any-p result) t) ; in any *package*. + (setq mode '&any)) + ((member arg lambda-list-keywords) + (setq mode '&unknown-junk) + (push arg (arglist.unknown-junk result))) + (t + (ecase mode + (&key + (push (decode-keyword-arg arg) + (arglist.keyword-args result))) + (&optional + (push (decode-optional-arg arg) + (arglist.optional-args result))) + (&body + (setf (arglist.body-p result) t + (arglist.rest result) arg)) + (&rest + (setf (arglist.rest result) arg)) + (&aux + (push (decode-optional-arg arg) + (arglist.aux-args result))) + ((nil) + (push (decode-required-arg arg) + (arglist.required-args result))) + ((&whole &environment) + (setf mode nil) + (push arg (arglist.known-junk result))) + (&any + (push arg (arglist.any-args result))))))) + (nreversef (arglist.required-args result)) + (nreversef (arglist.optional-args result)) + (nreversef (arglist.keyword-args result)) + (nreversef (arglist.aux-args result)) + (nreversef (arglist.any-args result)) + (nreversef (arglist.known-junk result)) + (nreversef (arglist.unknown-junk result)) + (assert (or (and (not (arglist.key-p result)) (not (arglist.any-p result))) + (exactly-one-p (arglist.key-p result) (arglist.any-p result)))) + result)) + +(defun encode-arglist (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)) + (when (arglist.key-p decoded-arglist) + '(&key)) + (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist)) + (when (arglist.allow-other-keys-p decoded-arglist) + '(&allow-other-keys)) + (when (arglist.any-args decoded-arglist) + `(&any ,@(arglist.any-args decoded-arglist))) + (cond ((not (arglist.rest decoded-arglist)) + '()) + ((arglist.body-p decoded-arglist) + `(&body ,(arglist.rest decoded-arglist))) + (t + `(&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. +As a secondary value, return whether &allow-other-keys appears." + (let ((decoded-arglist (decode-arglist arglist))) + (values (arglist.keyword-args decoded-arglist) + (arglist.allow-other-keys-p decoded-arglist)))) + +(defun methods-keywords (methods) + "Collect all keywords in the arglists of METHODS. +As a secondary value, return whether &allow-other-keys appears somewhere." + (let ((keywords '()) + (allow-other-keys nil)) + (dolist (method methods) + (multiple-value-bind (kw aok) + (arglist-keywords + (swank-mop:method-lambda-list method)) + (setq keywords (remove-duplicates (append keywords kw) + :key #'keyword-arg.keyword) + allow-other-keys (or allow-other-keys aok)))) + (values keywords allow-other-keys))) + +(defun generic-function-keywords (generic-function) + "Collect all keywords in the methods of GENERIC-FUNCTION. +As a secondary value, return whether &allow-other-keys appears somewhere." + (methods-keywords + (swank-mop:generic-function-methods generic-function))) + +(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 + (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 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)) + (print-decoded-arglist-as-template decoded-arglist + :prefix prefix + :suffix suffix))))) + +(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 (if (keywordp arg) (prin1 arg) (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))) + (dolist (any-arg (arglist.any-args decoded-arglist)) + (space) + (print-arg-or-pattern any-arg)) + (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. +As a tertiary value, return the initial sublist of ARGS that was needed +to determine the extra keywords.")) + +(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 (arglist-from-form-spec (ensure-list operator) + :remove-args nil))) + (unless (eql arglist :not-available) + (values + (arglist.keyword-args arglist) + (arglist.allow-other-keys-p arglist))))) + +(defmethod extra-keywords (operator &rest args) + ;; default method + (declare (ignore args)) + (let ((symbol-function (symbol-function operator))) + (if (typep symbol-function 'generic-function) + (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) + (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) + "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 + (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)) + +(defvar *remove-keywords-alist* + '((:test :test-not) + (:test-not :test))) + +(defun remove-actual-args (decoded-arglist actual-arglist) + "Remove from DECODED-ARGLIST the arguments that have already been +provided in ACTUAL-ARGLIST." + (assert (or (and (not (arglist.key-p decoded-arglist)) + (not (arglist.any-p decoded-arglist))) + (exactly-one-p (arglist.key-p decoded-arglist) + (arglist.any-p decoded-arglist)))) + (loop while (and actual-arglist + (arglist.required-args decoded-arglist)) + do (progn (pop actual-arglist) + (pop (arglist.required-args decoded-arglist)))) + (loop while (and actual-arglist + (arglist.optional-args decoded-arglist)) + do (progn (pop actual-arglist) + (pop (arglist.optional-args decoded-arglist)))) + (if (arglist.any-p decoded-arglist) + (remove-&any-args decoded-arglist actual-arglist) + (remove-&key-args decoded-arglist actual-arglist)) + decoded-arglist) + +(defun remove-&key-args (decoded-arglist key-args) + (loop for keyword in key-args by #'cddr + for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*)) + do (setf (arglist.keyword-args decoded-arglist) + (remove-if (lambda (kw) + (or (eql kw keyword) + (member kw keywords-to-remove))) + (arglist.keyword-args decoded-arglist) + :key #'keyword-arg.keyword))) ) + +(defun remove-&any-args (decoded-arglist any-args) + (setf (arglist.any-args decoded-arglist) + (remove-if #'(lambda (x) (member x any-args)) + (arglist.any-args decoded-arglist) + :key #'(lambda (x) (first (ensure-list x)))))) + + +(defun arglist-from-form-spec (form-spec &key (remove-args t)) + "Returns the decoded arglist that corresponds to FORM-SPEC. If +REMOVE-ARGS is T, the arguments that are contained in FORM-SPEC +are removed from the result arglist. + +Examples: + + (arglist-from-form-spec '(defun)) + + ~=> (name args &body body) + + (arglist-from-form-spec '(defun foo)) + + ~=> (args &body body) + + (arglist-from-form-spec '(defun foo) :remove-args nil)) + + ~=> (name args &body body)) + + (arglist-from-form-spec '((:type-specifier float) 42) :remove-args nil) + + ~=> (&optional lower-limit upper-limit) +" + (if (null form-spec) + :not-available + (multiple-value-bind (type operator arguments) + (split-form-spec form-spec) + (arglist-dispatch type operator arguments :remove-args remove-args)))) + + +(defmacro with-availability ((var) form &body body) + `(let ((,var ,form)) + (if (eql ,var :not-available) + :not-available + (progn ,@body)))) + +(defgeneric arglist-dispatch (operator-type operator arguments &key remove-args)) + +(defmethod arglist-dispatch (operator-type operator arguments &key (remove-args t)) + (when (and (symbolp operator) + (valid-operator-symbol-p operator)) + (multiple-value-bind (decoded-arglist determining-args any-enrichment) + (compute-enriched-decoded-arglist operator arguments) + (etypecase decoded-arglist + ((member :not-available) + :not-available) + (arglist + (cond + (remove-args + ;; get rid of formal args already provided + (remove-actual-args decoded-arglist arguments)) + (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 arglist-dispatch + (values decoded-arglist any-enrichment)))))) + :not-available) + +(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'defmethod)) + arguments &key (remove-args t)) + (when (and (listp arguments) + (not (null arguments)) ;have generic function name + (notany #'listp (rest arguments))) ;don't have arglist yet + (let* ((gf-name (first arguments)) + (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) + (with-availability (arglist) (arglist gf) + (return-from arglist-dispatch + (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)) + +(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'eval-when)) + arguments &key (remove-args t)) + (let ((eval-when-args '(:compile-toplevel :load-toplevel :execute))) + (make-arglist :required-args (list (maybecall remove-args #'remove-actual-args + (make-arglist :any-args eval-when-args) + arguments)) + :rest '#:body :body-p t))) + +(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'declare)) + arguments &key (remove-args t)) + ;; Catching 'DECLARE before SWANK-BACKEND:ARGLIST can barf. + (declare (ignore remove-args)) + (make-arglist :rest '#:decl-specifiers)) + +(defmethod arglist-dispatch ((operator-type (eql :declaration)) + decl-identifier decl-args &key (remove-args t)) + (with-availability (arglist) + (declaration-arglist decl-identifier) + (maybecall remove-args #'remove-actual-args + (decode-arglist arglist) decl-args)) + ;; We don't fall back to CALL-NEXT-METHOD because we're within a + ;; different namespace! + ) + +(defmethod arglist-dispatch ((operator-type (eql :type-specifier)) + type-specifier specifier-args &key (remove-args t)) + (with-availability (arglist) + (type-specifier-arglist type-specifier) + (maybecall remove-args #'remove-actual-args + (decode-arglist arglist) specifier-args)) + ;; No CALL-NEXT-METHOD, see above. + ) + + +(defun read-incomplete-form-from-string (form-string) + (with-buffer-syntax () + (call-with-ignored-reader-errors + #'(lambda () + (read-from-string form-string))))) + +(defun call-with-ignored-reader-errors (thunk) + (declare (type (function () (values &rest t)) thunk)) + (declare (optimize (speed 3) (safety 1))) + (handler-case (funcall thunk) + (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." + (multiple-value-bind (form newly-interned-symbols) + (parse-form-spec form-string) + (unwind-protect + (when (consp form) + (let ((form-completion (arglist-from-form-spec form))) + (unless (eql form-completion :not-available) + (return-from complete-form + (decoded-arglist-to-template-string form-completion + *buffer-package* + :prefix ""))))) + (mapc #'unintern-in-home-package newly-interned-symbols)) + :not-available)) + + +(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 (raw-specs keyword-string arg-index-specs) + (with-buffer-syntax () + (multiple-value-bind (form-spec position newly-interned-symbols) + (parse-first-valid-form-spec raw-specs) + (unwind-protect + (when form-spec + (let ((arglist (arglist-from-form-spec form-spec :remove-args nil))) + (unless (eql arglist :not-available) + (let* ((operator (nth-value 1 (split-form-spec form-spec))) + (indices (reverse (rest (subseq arg-index-specs 0 (1+ position))))) + (arglist (apply #'arglist-ref arglist operator 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 + (append (mapcar #'keyword-arg.keyword + (arglist.keyword-args arglist)) + (remove-if-not #'keywordp (arglist.any-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-compound-prefix completion-set)))))))) + (mapc #'unintern-in-home-package newly-interned-symbols))))) + + +(defun arglist-to-string (arglist package &key print-right-margin highlight) + (decoded-arglist-to-string (decode-arglist arglist) + :package 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 '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body) + "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)") + (test '(declare (optimize &any (speed 1) (safety 1))) + "(declare (optimize &any (speed 1) (safety 1)))") + )) + +(test-print-arglist) + +(provide :swank-arglists)
Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-asdf.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-asdf.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-asdf.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,63 @@ +;;; swank-asdf.el -- ASDF support +;; +;; Authors: Daniel Barlow dan@telent.net +;; Marco Baringer mb@bese.it +;; Edi Weitz edi@agharta.de +;; and others +;; License: Public Domain +;; + +(in-package :swank) + +(defslimefun operate-on-system-for-emacs (system-name operation &rest keywords) + "Compile and load SYSTEM using ASDF. +Record compiler notes signalled as `compiler-condition's." + (swank-compiler + (lambda () + (apply #'operate-on-system system-name operation keywords)))) + +(defun operate-on-system (system-name operation-name &rest keyword-args) + "Perform OPERATION-NAME on SYSTEM-NAME using ASDF. +The KEYWORD-ARGS are passed on to the operation. +Example: +(operate-on-system "SWANK" "COMPILE-OP" :force t)" + (with-compilation-hooks () + (let ((operation (find-symbol operation-name :asdf))) + (when (null operation) + (error "Couldn't find ASDF operation ~S" operation-name)) + (apply #'asdf:operate operation system-name keyword-args)))) + +(defun asdf-central-registry () + asdf:*central-registry*) + +(defslimefun list-all-systems-in-central-registry () + "Returns a list of all systems in ASDF's central registry." + (mapcar #'pathname-name + (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=))) + +(defslimefun list-all-systems-known-to-asdf () + "Returns a list of all systems ASDF knows already." + ;; ugh, yeah, it's unexported - but do we really expect this to + ;; change anytime soon? + (loop for name being the hash-keys of asdf::*defined-systems* + collect name)) + +(defslimefun list-asdf-systems () + "Returns the systems in ASDF's central registry and those which ASDF +already knows." + (nunion (list-all-systems-known-to-asdf) + (list-all-systems-in-central-registry) + :test #'string=)) + +(provide :swank-asdf)
Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-c-p-c.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-c-p-c.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-c-p-c.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,279 @@ +;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion +;; +;; Author: Luke Gorrie luke@synap.se +;; Edi Weitz edi@agharta.de +;; Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de +;; Tobias C. Rittweiler tcr@freebits.de +;; and others +;; +;; License: Public Domain +;; + + +(in-package :swank) + +(defslimefun completions (string default-package-name) + "Return a list of completions for a symbol designator STRING. + +The result is the list (COMPLETION-SET COMPLETED-PREFIX), where +COMPLETION-SET is the list of all matching completions, and +COMPLETED-PREFIX is the best (partial) completion of the input +string. + +Simple compound matching is supported on a per-hyphen basis: + + (completions "m-v-" "COMMON-LISP") + ==> (("multiple-value-bind" "multiple-value-call" + "multiple-value-list" "multiple-value-prog1" + "multiple-value-setq" "multiple-values-limit") + "multiple-value") + +(For more advanced compound matching, see FUZZY-COMPLETIONS.) + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. + +The way symbols are matched depends on the symbol designator's +format. The cases are as follows: + FOO - Symbols with matching prefix and accessible in the buffer package. + PKG:FOO - Symbols with matching prefix and external in package PKG. + PKG::FOO - Symbols with matching prefix and accessible in package PKG. +" + (let ((completion-set (completion-set string default-package-name + #'compound-prefix-match))) + (when completion-set + (list completion-set (longest-compound-prefix completion-set))))) + +;;;;; Find completion set + +(defun completion-set (string default-package-name matchp) + "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 (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 (completion-output-symbol-converter string))) + (flet ((symbol-matches-p (symbol) + (and (or (not external) + (symbol-external-p symbol package)) + (funcall test string + (funcall converter (symbol-name symbol)))))) + (do-symbols* (symbol package) + (when (symbol-matches-p symbol) + (push symbol completions)))) + completions)) + +(defun find-matching-symbols-in-list (string list test) + "Return a list of symbols in LIST matching STRING. +TEST is called with two strings." + (let ((completions '()) + (converter (completion-output-symbol-converter string))) + (flet ((symbol-matches-p (symbol) + (funcall test string + (funcall converter (symbol-name symbol))))) + (dolist (symbol list) + (when (symbol-matches-p symbol) + (push symbol completions)))) + (remove-duplicates completions))) + +(defun find-matching-packages (name matcher) + "Return a list of package names matching NAME with MATCHER. +MATCHER is a two-argument predicate." + (let ((to-match (string-upcase name))) + (remove-if-not (lambda (x) (funcall matcher to-match x)) + (mapcar (lambda (pkgname) + (concatenate 'string pkgname ":")) + (loop for package in (list-all-packages) + collect (package-name package) + append (package-nicknames package)))))) + + +;; PARSE-COMPLETION-ARGUMENTS return table: +;; +;; user behaviour | NAME | PACKAGE-NAME | PACKAGE +;; ----------------+--------+--------------+----------------------------------- +;; asdf [tab] | "asdf" | NIL | #<PACKAGE "DEFAULT-PACKAGE-NAME"> +;; | | | or *BUFFER-PACKAGE* +;; asdf: [tab] | "" | "asdf" | #<PACKAGE "ASDF"> +;; | | | +;; asdf:foo [tab] | "foo" | "asdf" | #<PACKAGE "ASDF"> +;; | | | +;; as:fo [tab] | "fo" | "as" | NIL +;; | | | +;; : [tab] | "" | "" | #<PACKAGE "KEYWORD"> +;; | | | +;; :foo [tab] | "foo" | "" | #<PACKAGE "KEYWORD"> +;; +(defun parse-completion-arguments (string default-package-name) + "Parse STRING as a symbol designator. +Return these values: + SYMBOL-NAME + PACKAGE-NAME, or nil if the designator does not include an explicit package. + PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is + NIL, return the respective package of DEFAULT-PACKAGE-NAME instead; + if PACKAGE is non-NIL but a package cannot be found under that name, + return NIL.) + INTERNAL-P, if the symbol is qualified with `::'." + (multiple-value-bind (name package-name internal-p) + (tokenize-symbol string) + (if package-name + (let ((package (guess-package (if (equal package-name "") + "KEYWORD" + package-name)))) + (values name package-name package internal-p)) + (let ((package (guess-package default-package-name))) + (values name package-name (or package *buffer-package*) internal-p)) + ))) + + + +(defun completion-output-case-converter (input &optional with-escaping-p) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case." + (ecase (readtable-case *readtable*) + (:upcase (cond ((or with-escaping-p + (not (some #'lower-case-p input))) + #'identity) + (t #'string-downcase))) + (:invert (lambda (output) + (multiple-value-bind (lower upper) (determine-case output) + (cond ((and lower upper) output) + (lower (string-upcase output)) + (upper (string-downcase output)) + (t output))))) + (:downcase (cond ((or with-escaping-p + (not (some #'upper-case-p input))) + #'identity) + (t #'string-upcase))) + (:preserve #'identity))) + +(defun completion-output-package-converter (input) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case." + (completion-output-case-converter input)) + +(defun completion-output-symbol-converter (input) + "Return a function to convert strings for the completion output. +INPUT is used to guess the preferred case. Escape symbols when needed." + (let ((case-converter (completion-output-case-converter input)) + (case-converter-with-escaping (completion-output-case-converter input t))) + (lambda (str) + (if (or (multiple-value-bind (lowercase uppercase) + (determine-case str) + ;; In these readtable cases, symbols with letters from + ;; the wrong case need escaping + (case (readtable-case *readtable*) + (:upcase lowercase) + (:downcase uppercase) + (t nil))) + (some (lambda (el) + (or (member el '(#: #\Space #\Newline #\Tab)) + (multiple-value-bind (macrofun nonterminating) + (get-macro-character el) + (and macrofun + (not nonterminating))))) + str)) + (concatenate 'string "|" (funcall case-converter-with-escaping str) "|") + (funcall case-converter str))))) + + +(defun determine-case (string) + "Return two booleans LOWER and UPPER indicating whether STRING +contains lower or upper case characters." + (values (some #'lower-case-p string) + (some #'upper-case-p string))) + + +;;;;; Compound-prefix matching + +(defun make-compound-prefix-matcher (delimeter &key (test #'char=)) + "Returns a matching function that takes a `prefix' and a +`target' string and which returns T if `prefix' is a +compound-prefix of `target', and otherwise NIL. + +Viewing each of `prefix' and `target' as a series of substrings +delimited by DELIMETER, if each substring of `prefix' is a prefix +of the corresponding substring in `target' then we call `prefix' +a compound-prefix of `target'." + (lambda (prefix target) + (declare (type simple-string prefix target)) + (loop for ch across prefix + with tpos = 0 + always (and (< tpos (length target)) + (if (char= ch delimeter) + (setf tpos (position #- target :start tpos)) + (funcall test ch (aref target tpos)))) + do (incf tpos)))) + +(defun compound-prefix-match (prefix target) + "Examples: +(compound-prefix-match "foo" "foobar") => t +(compound-prefix-match "m--b" "multiple-value-bind") => t +(compound-prefix-match "m-v-c" "multiple-value-bind") => NIL +" + (funcall (make-compound-prefix-matcher #-) prefix target)) + + +;;;;; Extending the input string by completion + +(defun longest-compound-prefix (completions &optional (delimeter #-)) + "Return the longest compound _prefix_ for all COMPLETIONS." + (flet ((tokenizer (string) (tokenize-completion string delimeter))) + (untokenize-completion + (loop for token-list in (transpose-lists (mapcar #'tokenizer completions)) + if (notevery #'string= token-list (rest token-list)) + collect (longest-common-prefix token-list) ; Note that we possibly collect + and do (loop-finish) ; the "" here as well, so that + else collect (first token-list))))) ; UNTOKENIZE-COMPLETION will + ; append a hyphen for us. +(defun tokenize-completion (string delimeter) + "Return all substrings of STRING delimited by DELIMETER." + (loop with end + for start = 0 then (1+ end) + until (> start (length string)) + do (setq end (or (position delimeter string :start start) (length string))) + collect (subseq string start end))) + +(defun untokenize-completion (tokens) + (format nil "~{~A~^-~}" tokens)) + +(defun transpose-lists (lists) + "Turn a list-of-lists on its side. +If the rows are of unequal length, truncate uniformly to the shortest. + +For example: +(transpose-lists '((ONE TWO THREE) (1 2))) + => ((ONE 1) (TWO 2))" + (cond ((null lists) '()) + ((some #'null lists) '()) + (t (cons (mapcar #'car lists) + (transpose-lists (mapcar #'cdr lists)))))) + + +;;;; Completion for character names + +(defslimefun completions-for-character (prefix) + (let* ((matcher (make-compound-prefix-matcher #_ :test #'char-equal)) + (completion-set (character-completion-set prefix matcher)) + (completions (sort completion-set #'string<))) + (list completions (longest-compound-prefix completions #_)))) + +(provide :swank-c-p-c) \ No newline at end of file
Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,737 @@ +;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects +;; +;; Author: Marco Baringer mb@bese.it and others +;; License: Public Domain +;; + +(in-package :swank) + +;; Subclass `backend-inspector' so that backend specific methods are +;; also considered. +(defclass fancy-inspector (backend-inspector) ()) + +(defmethod inspect-for-emacs ((symbol symbol) (inspector fancy-inspector)) + (declare (ignore inspector)) + (let ((package (symbol-package symbol))) + (multiple-value-bind (_symbol status) + (and package (find-symbol (string symbol) package)) + (declare (ignore _symbol)) + (values + "A symbol." + (append + (label-value-line "Its name is" (symbol-name symbol)) + ;; + ;; 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))) + (t '("It is unbound." (:newline)))) + (docstring-ispec "Documentation" symbol 'variable) + (multiple-value-bind (expansion definedp) (macroexpand symbol) + (if definedp + (label-value-line "It is a symbol macro with expansion" + expansion))) + ;; + ;; Function + (if (fboundp symbol) + (append (if (macro-function symbol) + `("It a macro with macro-function: " + (:value ,(macro-function symbol))) + `("It is a function: " + (:value ,(symbol-function symbol)))) + `(" " (:action "[make funbound]" + ,(lambda () (fmakunbound symbol)))) + `((:newline))) + `("It has no function value." (:newline))) + (docstring-ispec "Function Documentation" symbol 'function) + (if (compiler-macro-function symbol) + (label-value-line "It also names the compiler macro" + (compiler-macro-function symbol))) + (docstring-ispec "Compiler Macro Documentation" + symbol 'compiler-macro) + ;; + ;; Package + (if package + `("It is " ,(string-downcase (string status)) + " to the package: " + (:value ,package ,(package-name package)) + ,@(if (eq :internal status) + `(" " + (:action "[export it]" + ,(lambda () (export symbol package))))) + " " + (:action "[unintern it]" + ,(lambda () (unintern symbol package))) + (:newline)) + '("It is a non-interned symbol." (:newline))) + ;; + ;; Plist + (label-value-line "Property list" (symbol-plist symbol)) + ;; + ;; Class + (if (find-class symbol nil) + `("It names the class " + (:value ,(find-class symbol) ,(string symbol)) + " " + (:action "[remove]" + ,(lambda () (setf (find-class symbol) nil))) + (:newline))) + ;; + ;; More package + (if (find-package symbol) + (label-value-line "It names the package" (find-package symbol))) + ))))) + +(defun docstring-ispec (label object kind) + "Return a inspector spec if OBJECT has a docstring of of kind KIND." + (let ((docstring (documentation object kind))) + (cond ((not docstring) nil) + ((< (+ (length label) (length docstring)) + 75) + (list label ": " docstring '(:newline))) + (t + (list label ": " '(:newline) " " docstring '(:newline)))))) + +(defmethod inspect-for-emacs ((f function) (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A function." + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(inspector-princ (arglist f)) (:newline)) + (docstring-ispec "Documentation" f t) + (if (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f)))))) + +(defun method-specializers-for-inspect (method) + "Return a "pretty" list of the method's specializers. Normal + specializers are replaced by the name of the class, eql + specializers are replaced by `(eql ,object)." + (mapcar (lambda (spec) + (typecase spec + (swank-mop:eql-specializer + `(eql ,(swank-mop:eql-specializer-object spec))) + (t (swank-mop:class-name spec)))) + (swank-mop:method-specializers method))) + +(defun method-for-inspect-value (method) + "Returns a "pretty" list describing METHOD. The first element + of the list is the name of generic-function method is + specialiazed on, the second element is the method qualifiers, + the rest of the list is the method's specialiazers (as per + method-specializers-for-inspect)." + (append (list (swank-mop:generic-function-name + (swank-mop:method-generic-function method))) + (swank-mop:method-qualifiers method) + (method-specializers-for-inspect method))) + +(defmethod inspect-for-emacs ((object standard-object) + (inspector fancy-inspector)) + (let ((class (class-of object))) + (values "An object." + `("Class: " (:value ,class) (:newline) + ,@(all-slots-for-inspector object inspector))))) + +(defvar *gf-method-getter* 'methods-by-applicability + "This function is called to get the methods of a generic function. +The default returns the method sorted by applicability. +See `methods-by-applicability'.") + +(defun specializer< (specializer1 specializer2) + "Return true if SPECIALIZER1 is more specific than SPECIALIZER2." + (let ((s1 specializer1) (s2 specializer2) ) + (cond ((typep s1 'swank-mop:eql-specializer) + (not (typep s2 'swank-mop:eql-specializer))) + (t + (flet ((cpl (class) + (and (swank-mop:class-finalized-p class) + (swank-mop:class-precedence-list class)))) + (member s2 (cpl s1))))))) + +(defun methods-by-applicability (gf) + "Return methods ordered by most specific argument types. + +`method-specializer<' is used for sorting." + ;; FIXME: argument-precedence-order and qualifiers are ignored. + (labels ((method< (meth1 meth2) + (loop for s1 in (swank-mop:method-specializers meth1) + for s2 in (swank-mop:method-specializers meth2) + do (cond ((specializer< s2 s1) (return nil)) + ((specializer< s1 s2) (return t)))))) + (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) #'method<))) + +(defun abbrev-doc (doc &optional (maxlen 80)) + "Return the first sentence of DOC, but not more than MAXLAN characters." + (subseq doc 0 (min (1+ (or (position #. doc) (1- maxlen))) + maxlen + (length doc)))) + +(defgeneric inspect-slot-for-emacs (class object slot) + (:method (class object slot) + (let ((slot-name (swank-mop:slot-definition-name slot)) + (boundp (swank-mop:slot-boundp-using-class class object slot))) + `(,@(if boundp + `((:value ,(swank-mop:slot-value-using-class class object slot))) + `("#<unbound>")) + " " + (:action "[set value]" + ,(lambda () (with-simple-restart + (abort "Abort setting slot ~S" slot-name) + (let ((value-string (eval-in-emacs + `(condition-case c + (slime-read-object + ,(format nil "Set slot ~S to (evaluated) : " slot-name)) + (quit nil))))) + (when (and value-string + (not (string= value-string ""))) + (setf (swank-mop:slot-value-using-class class object slot) + (eval (read-from-string value-string)))))))) + ,@(when boundp + `(" " (:action "[make unbound]" + ,(lambda () (swank-mop:slot-makunbound-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)) + (let* ((class (class-of object)) + (direct-slots (swank-mop:class-direct-slots class)) + (effective-slots (sort (copy-seq (swank-mop:class-slots class)) + #'string< :key #'swank-mop:slot-definition-name)) + (slot-presentations (loop for effective-slot :in effective-slots + collect (inspect-slot-for-emacs + class object effective-slot))) + (longest-slot-name-length + (loop for slot :in effective-slots + maximize (length (symbol-name + (swank-mop:slot-definition-name slot)))))) + (loop + for effective-slot :in effective-slots + for slot-presentation :in slot-presentations + for direct-slot = (find (swank-mop:slot-definition-name effective-slot) + direct-slots :key #'swank-mop:slot-definition-name) + for slot-name = (inspector-princ + (swank-mop:slot-definition-name effective-slot)) + for padding-length = (- longest-slot-name-length + (length (symbol-name + (swank-mop:slot-definition-name + effective-slot)))) + collect `(:value ,(if direct-slot + (list direct-slot effective-slot) + effective-slot) + ,slot-name) + collect (make-array padding-length + :element-type 'character + :initial-element #\Space) + collect " = " + append slot-presentation + collect '(:newline)))))) + +(defmethod inspect-for-emacs ((gf standard-generic-function) + (inspector fancy-inspector)) + (flet ((lv (label value) (label-value-line label value))) + (values + "A generic function." + (append + (lv "Name" (swank-mop:generic-function-name gf)) + (lv "Arguments" (swank-mop:generic-function-lambda-list gf)) + (docstring-ispec "Documentation" gf t) + (lv "Method class" (swank-mop:generic-function-method-class gf)) + (lv "Method combination" + (swank-mop:generic-function-method-combination gf)) + `("Methods: " (:newline)) + (loop for method in (funcall *gf-method-getter* gf) append + `((:value ,method ,(inspector-princ + ;; drop the name of the GF + (cdr (method-for-inspect-value method)))) + " " + (:action "[remove method]" + ,(let ((m method)) ; LOOP reassigns method + (lambda () + (remove-method gf m)))) + (:newline))) + `((:newline)) + (all-slots-for-inspector gf inspector))))) + +(defmethod inspect-for-emacs ((method standard-method) + (inspector fancy-inspector)) + (values "A method." + `("Method defined on the generic function " + (:value ,(swank-mop:method-generic-function method) + ,(inspector-princ + (swank-mop:generic-function-name + (swank-mop:method-generic-function method)))) + (:newline) + ,@(docstring-ispec "Documentation" method t) + "Lambda List: " (:value ,(swank-mop:method-lambda-list method)) + (:newline) + "Specializers: " (:value ,(swank-mop:method-specializers method) + ,(inspector-princ (method-specializers-for-inspect method))) + (:newline) + "Qualifiers: " (:value ,(swank-mop:method-qualifiers method)) + (:newline) + "Method function: " (:value ,(swank-mop:method-function method)) + (:newline) + ,@(all-slots-for-inspector method inspector)))) + +(defmethod inspect-for-emacs ((class standard-class) + (inspector fancy-inspector)) + (values "A class." + `("Name: " (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(common-seperated-spec + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ + (swank-mop:slot-definition-name slot))))) + '("#<N/A (class not finalized)>")) + (: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) + `(:value ,sub ,(inspector-princ (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class ,(inspector-princ (class-name class))))) + '("#<N/A (class not finalized)>")) + (:newline) + ,@(when (swank-mop:specializer-direct-methods class) + `("It is used as a direct specializer in the following methods:" (:newline) + ,@(loop + for method in (sort (copy-seq (swank-mop:specializer-direct-methods class)) + #'string< :key (lambda (x) + (symbol-name + (let ((name (swank-mop::generic-function-name + (swank-mop::method-generic-function x)))) + (if (symbolp name) name (second name)))))) + collect " " + collect `(:value ,method ,(inspector-princ (method-for-inspect-value method))) + collect '(:newline) + if (documentation method t) + collect " Documentation: " and + collect (abbrev-doc (documentation method t)) and + collect '(:newline)))) + "Prototype: " ,(if (swank-mop:class-finalized-p class) + `(:value ,(swank-mop:class-prototype class)) + '"#<N/A (class not finalized)>") + (:newline) + ,@(all-slots-for-inspector class inspector)))) + +(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) + (inspector fancy-inspector)) + (values "A slot." + `("Name: " (:value ,(swank-mop:slot-definition-name slot)) + (:newline) + ,@(when (swank-mop:slot-definition-documentation slot) + `("Documentation:" (:newline) + (:value ,(swank-mop:slot-definition-documentation slot)) + (:newline))) + "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline) + "Init form: " ,(if (swank-mop:slot-definition-initfunction slot) + `(:value ,(swank-mop:slot-definition-initform slot)) + "#<unspecified>") (:newline) + "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) + (:newline) + ,@(all-slots-for-inspector slot inspector)))) + + +;; Wrapper structure over the list of symbols of a package that should +;; be displayed with their respective classification flags. This is +;; because we need a unique type to dispatch on in INSPECT-FOR-EMACS. +;; Used by the Inspector for packages. +(defstruct (%package-symbols-container (:conc-name %container.) + (:constructor %%make-package-symbols-container)) + title ;; A string; the title of the inspector page in Emacs. + description ;; A list of renderable objects; used as description. + symbols ;; A list of symbols. Supposed to be sorted alphabetically. + grouping-kind ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING. + ) + +(defun %make-package-symbols-container (&key title description symbols) + (%%make-package-symbols-container :title title :description description + :symbols symbols :grouping-kind :symbol)) + +(defgeneric make-symbols-listing (grouping-kind symbols)) + +(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols) + "Returns an object renderable by Emacs' inspector side that +alphabetically lists all the symbols in SYMBOLS together with a +concise string representation of what each symbol +represents (cf. CLASSIFY-SYMBOL & Fuzzy Completion.)" + (let ((max-length (loop for s in symbols maximizing (length (symbol-name s)))) + (distance 10)) ; empty distance between name and classification + (flet ((string-representations (symbol) + (let* ((name (symbol-name symbol)) + (length (length name)) + (padding (- max-length length)) + (classification (classify-symbol symbol))) + (values + (concatenate 'string + name + (make-string (+ padding distance) :initial-element #\Space)) + (symbol-classification->string classification))))) + `("" ; 8 is (length "Symbols:") + "Symbols:" ,(make-string (+ -8 max-length distance) :initial-element #\Space) "Flags:" + (:newline) + ,(concatenate 'string ; underlining dashes + (make-string (+ max-length distance -1) :initial-element #-) + " " + (let* ((dummy (classify-symbol (gensym))) + (dummy (symbol-classification->string dummy)) + (classification-length (length dummy))) + (make-string classification-length :initial-element #-))) + (:newline) + ,@(loop for symbol in symbols appending + (multiple-value-bind (symbol-string classification-string) + (string-representations symbol) + `((:value ,symbol ,symbol-string) ,classification-string + (:newline) + ))))))) + +(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols) + "For each possible classification (cf. CLASSIFY-SYMBOL), group +all the symbols in SYMBOLS to all of their respective +classifications. (If a symbol is, for instance, boundp and a +generic-function, it'll appear both below the BOUNDP group and +the GENERIC-FUNCTION group.) As macros and special-operators are +specified to be FBOUNDP, there is no general FBOUNDP group, +instead there are the three explicit FUNCTION, MACRO and +SPECIAL-OPERATOR groups." + (let ((table (make-hash-table :test #'eq))) + (flet ((maybe-convert-fboundps (classifications) + ;; Convert an :FBOUNDP in CLASSIFICATIONS to :FUNCTION if possible. + (if (and (member :fboundp classifications) + (not (member :macro classifications)) + (not (member :special-operator classifications))) + (substitute :function :fboundp classifications) + (remove :fboundp classifications)))) + (loop for symbol in symbols do + (loop for classification in (maybe-convert-fboundps (classify-symbol symbol)) + ;; SYMBOLS are supposed to be sorted alphabetically; + ;; this property is preserved here except for reversing. + do (push symbol (gethash classification table))))) + (let* ((classifications (loop for k being each hash-key in table collect k)) + (classifications (sort classifications #'string<))) + (loop for classification in classifications + for symbols = (gethash classification table) + appending`(,(symbol-name classification) + (:newline) + ,(make-string 64 :initial-element #-) + (:newline) + ,@(mapcan #'(lambda (symbol) + (list `(:value ,symbol ,(symbol-name symbol)) '(:newline))) + (nreverse symbols)) ; restore alphabetic orderness. + (:newline) + ))))) + +(defmethod inspect-for-emacs ((%container %package-symbols-container) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (with-struct (%container. title description symbols grouping-kind) %container + (values title + `(,@description + (:newline) + " " ,(ecase grouping-kind + (:symbol + `(:action "[Group by classification]" + ,(lambda () (setf grouping-kind :classification)) + :refreshp t)) + (:classification + `(:action "[Group by symbol]" + ,(lambda () (setf grouping-kind :symbol)) + :refreshp t))) + (:newline) (:newline) + ,@(make-symbols-listing grouping-kind symbols))))) + + +(defmethod inspect-for-emacs ((package package) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (let ((package-name (package-name package)) + (package-nicknames (package-nicknames package)) + (package-use-list (package-use-list package)) + (package-used-by-list (package-used-by-list package)) + (shadowed-symbols (package-shadowing-symbols package)) + (present-symbols '()) (present-symbols-length 0) + (internal-symbols '()) (internal-symbols-length 0) + (external-symbols '()) (external-symbols-length 0)) + + (do-symbols* (sym package) + (let ((status (symbol-status sym package))) + (when (not (eq status :inherited)) + (push sym present-symbols) (incf present-symbols-length) + (if (eq status :internal) + (progn (push sym internal-symbols) (incf internal-symbols-length)) + (progn (push sym external-symbols) (incf external-symbols-length)))))) + + (setf package-nicknames (sort (copy-list package-nicknames) #'string<) + package-use-list (sort (copy-list package-use-list) #'string< :key #'package-name) + package-used-by-list (sort (copy-list package-used-by-list) #'string< :key #'package-name) + shadowed-symbols (sort (copy-list shadowed-symbols) #'string<)) + + (setf present-symbols (sort present-symbols #'string<) ; SORT + STRING-LESSP + internal-symbols (sort internal-symbols #'string<) ; conses on at least + external-symbols (sort external-symbols #'string<)) ; SBCL 0.9.18. + + + (values + "A package." + `("" ; dummy to preserve indentation. + "Name: " (:value ,package-name) (:newline) + + "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline) + + ,@(when (documentation package t) + `("Documentation:" (:newline) ,(documentation package t) (:newline))) + + "Use list: " ,@(common-seperated-spec + package-use-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + "Used by list: " ,@(common-seperated-spec + package-used-by-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + ,@ ; ,@(flet ((...)) ...) would break indentation in Emacs. + (flet ((display-link (type symbols length &key title description) + (if (null symbols) + (format nil "0 ~A symbols." type) + `(:value ,(%make-package-symbols-container :title title + :description description + :symbols symbols) + ,(format nil "~D ~A symbol~P." length type length))))) + + `(,(display-link "present" present-symbols present-symbols-length + :title (format nil "All present symbols of package "~A"" package-name) + :description + '("A symbol is considered present in a package if it's" (:newline) + ""accessible in that package directly, rather than" (:newline) + "being inherited from another package."" (:newline) + "(CLHS glossary entry for `present')" (:newline))) + + (:newline) + ,(display-link "external" external-symbols external-symbols-length + :title (format nil "All external symbols of package "~A"" package-name) + :description + '("A symbol is considered external of a package if it's" (:newline) + ""part of the `external interface' to the package and" (:newline) + "[is] inherited by any other package that uses the" (:newline) + "package." (CLHS glossary entry of `external')" (:newline))) + (:newline) + ,(display-link "internal" internal-symbols internal-symbols-length + :title (format nil "All internal symbols of package "~A"" package-name) + :description + '("A symbol is considered internal of a package if it's" (:newline) + "present and not external---that is if the package is" (:newline) + "the home package of the symbol, or if the symbol has" (:newline) + "been explicitly imported into the package." (:newline) + (:newline) + "Notice that inherited symbols will thus not be listed," (:newline) + "which deliberately deviates from the CLHS glossary" (:newline) + "entry of `internal' because it's assumed to be more" (:newline) + "useful this way." (:newline))) + (:newline) + ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols) + :title (format nil "All shadowed symbols of package "~A"" package-name) + :description nil))))))) + + +(defmethod inspect-for-emacs ((pathname pathname) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values (if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + (append (label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname)))))) + +(defmethod inspect-for-emacs ((pathname logical-pathname) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A logical pathname." + (append + (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)) + (label-value-line* + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname)) + ("Truename" (if (not (wild-pathname-p pathname)) + (probe-file pathname))))))) + +(defmethod inspect-for-emacs ((n number) + (inspector fancy-inspector)) + (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 fancy-inspector)) + (declare (ignore inspector)) + (values "A number." + (append + `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]" + i i i i (ignore-errors (coerce i 'float))) + (:newline)) + (when (< -1 i char-code-limit) + (label-value-line "Code-char" (code-char i))) + (label-value-line "Integer-length" (integer-length i)) + (ignore-errors + (label-value-line "Universal-time" (format-iso8601-time i t)))))) + +(defmethod inspect-for-emacs ((c complex) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A complex number." + (label-value-line* + ("Real part" (realpart c)) + ("Imaginary part" (imagpart c))))) + +(defmethod inspect-for-emacs ((r ratio) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A non-integer ratio." + (label-value-line* + ("Numerator" (numerator r)) + ("Denominator" (denominator r)) + ("As float" (float r))))) + +(defmethod inspect-for-emacs ((f float) + (inspector fancy-inspector)) + (declare (ignore inspector)) + (values "A floating point number." + (cond + ((> f most-positive-long-float) + (list "Positive infinity.")) + ((< f most-negative-long-float) + (list "Negative infinity.")) + ((not (= f f)) + (list "Not a Number.")) + (t + (multiple-value-bind (significand exponent sign) (decode-float f) + (append + `("Scientific: " ,(format nil "~E" f) (:newline) + "Decoded: " + (:value ,sign) " * " + (:value ,significand) " * " + (:value ,(float-radix f)) "^" (:value ,exponent) (:newline)) + (label-value-line "Digits" (float-digits f)) + (label-value-line "Precision" (float-precision f)))))))) + +(defmethod inspect-for-emacs ((stream file-stream) + (inspector fancy-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)))) + :refreshp nil) + (:newline)) + content)))) + +(defmethod inspect-for-emacs ((condition stream-error) + (inspector fancy-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)))) + :refreshp nil) + (:newline)) + content)) + (values title content))))) + +(defvar *fancy-inpector-undo-list* nil) + +(defslimefun fancy-inspector-init () + (let ((i *default-inspector*)) + (push (lambda () (setq *default-inspector* i)) + *fancy-inpector-undo-list*)) + (setq *default-inspector* (make-instance 'fancy-inspector)) + t) + +(defslimefun fancy-inspector-unload () + (loop while *fancy-inpector-undo-list* do + (funcall (pop *fancy-inpector-undo-list*)))) + +(provide :swank-fancy-inspector) \ No newline at end of file
Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,620 @@ +;;; swank-fuzzy.lisp --- fuzzy symbol completion +;; +;; Authors: Brian Downing bdowning@lavos.net +;; Tobias C. Rittweiler tcr@freebits.de +;; and others +;; +;; License: Public Domain +;; + + +(in-package :swank) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (swank-require :swank-c-p-c)) + +;;; For nomenclature of the fuzzy completion section, please read +;;; through the following docstring. + +(defslimefun fuzzy-completions (string default-package-name &key limit time-limit-in-msec) +"Returns a list of two values: + + An (optionally limited to LIMIT best results) list of fuzzy + completions for a symbol designator STRING. The list will be + sorted by score, most likely match first. + + A flag that indicates whether or not TIME-LIMIT-IN-MSEC has + been exhausted during computation. If that parameter's value is + NIL or 0, no time limit is assumed. + +The main result is a list of completion objects, where a completion +object is: + + (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS) + +where a CHUNK is a description of a matched substring: + + (OFFSET SUBSTRING) + +and FLAGS is a list of keywords describing properties of the +symbol (see CLASSIFY-SYMBOL). + +E.g., completing "mvb" in a package that uses COMMON-LISP would +return something like: + + (("multiple-value-bind" 26.588236 ((0 "m") (9 "v") (15 "b")) + (:FBOUNDP :MACRO)) + ...) + +If STRING is package qualified the result list will also be +qualified. If string is non-qualified the result strings are +also not qualified and are considered relative to +DEFAULT-PACKAGE-NAME. + +Which symbols are candidates for matching depends on the symbol +designator's format. The cases are as follows: + FOO - Symbols accessible in the buffer package. + PKG:FOO - Symbols external in package PKG. + PKG::FOO - Symbols accessible in package PKG." + ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC + ;; to denote an infinite time limit. Internally, we only use NIL for + ;; that purpose, to be able to distinguish between "no time limit + ;; alltogether" and "current time limit already exhausted." So we've + ;; got to canonicalize its value at first: + (let* ((no-time-limit-p (or (not time-limit-in-msec) (zerop time-limit-in-msec))) + (time-limit (if no-time-limit-p nil time-limit-in-msec))) + (multiple-value-bind (completion-set interrupted-p) + (fuzzy-completion-set string default-package-name :limit limit + :time-limit-in-msec time-limit) + ;; We may send this as elisp [] arrays to spare a coerce here, + ;; but then the network serialization were slower by handling arrays. + ;; Instead we limit the number of completions that is transferred + ;; (the limit is set from Emacs.) + (list (coerce completion-set 'list) interrupted-p)))) + + +;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion +;;; object that will be sent back to Emacs, as described above. + +(defstruct (fuzzy-matching (:conc-name fuzzy-matching.) + (:predicate fuzzy-matching-p) + (:constructor %make-fuzzy-matching)) + symbol ; The symbol that has been found to match. + package-name ; The name of the package where SYMBOL was found in. + ; (This is not necessarily the same as the home-package + ; of SYMBOL, because the SYMBOL can be internal to + ; lots of packages; also think of package nicknames.) + score ; The higher the better SYMBOL is a match. + package-chunks ; Chunks pertaining to the package identifier of SYMBOL. + symbol-chunks) ; Chunks pertaining to SYMBOL's name. + +(defun make-fuzzy-matching (symbol package-name score package-chunks symbol-chunks) + (declare (inline %make-fuzzy-matching)) + (%make-fuzzy-matching :symbol symbol :package-name package-name :score score + :package-chunks package-chunks + :symbol-chunks symbol-chunks)) + +(defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string) + (multiple-value-bind (_ user-package-name __ input-internal-p) + (parse-completion-arguments user-input-string nil) + (declare (ignore _ __)) + (with-struct (fuzzy-matching. score symbol package-name package-chunks symbol-chunks) + fuzzy-matching + (let (symbol-name real-package-name internal-p) + (cond (symbol ; symbol fuzzy matching? + (setf symbol-name (symbol-name symbol)) + (setf internal-p input-internal-p) + (setf real-package-name (cond ((keywordp symbol) "") + ((not user-package-name) nil) + (t package-name)))) + (t ; package fuzzy matching? + (setf symbol-name "") + (setf real-package-name package-name) + ;; If no explicit package name was given by the user + ;; (e.g. input was "asdf"), we want to append only + ;; one colon ":" to the package names. + (setf internal-p (if user-package-name input-internal-p nil)))) + (values symbol-name + real-package-name + (if user-package-name internal-p nil) + (completion-output-symbol-converter user-input-string) + (completion-output-package-converter user-input-string)))))) + +(defun fuzzy-format-matching (fuzzy-matching user-input-string) + "Returns the completion ("foo:bar") that's represented by FUZZY-MATCHING." + (multiple-value-bind (symbol-name package-name internal-p symbol-converter package-converter) + (%fuzzy-extract-matching-info fuzzy-matching user-input-string) + (setq symbol-name (and symbol-name (funcall symbol-converter symbol-name))) + (setq package-name (and package-name (funcall package-converter package-name))) + (let ((result (untokenize-symbol package-name internal-p symbol-name))) + ;; We return the length of the possibly added prefix as second value. + (values result (search symbol-name result))))) + +(defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string) + "Converts a result from the fuzzy completion core into +something that emacs is expecting. Converts symbols to strings, +fixes case issues, and adds information describing if the symbol +is :bound, :fbound, a :class, a :macro, a :generic-function, +a :special-operator, or a :package." + (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks) fuzzy-matching + (multiple-value-bind (name added-length) + (fuzzy-format-matching fuzzy-matching user-input-string) + (list name + score + (append package-chunks + (mapcar #'(lambda (chunk) + ;; Fix up chunk positions to account for possible + ;; added package identifier. + (let ((offset (first chunk)) (string (second chunk))) + (list (+ added-length offset) string))) + symbol-chunks)) + (classify-symbol symbol))))) + +(defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec) + "Returns two values: an array of completion objects, sorted by +their score, that is how well they are a match for STRING +according to the fuzzy completion algorithm. If LIMIT is set, +only the top LIMIT results will be returned. Additionally, a flag +is returned that indicates whether or not TIME-LIMIT-IN-MSEC was +exhausted." + (check-type limit (or null (integer 0 #.(1- most-positive-fixnum)))) + (check-type time-limit-in-msec (or null (integer 0 #.(1- most-positive-fixnum)))) + (multiple-value-bind (matchings interrupted-p) + (fuzzy-generate-matchings string default-package-name time-limit-in-msec) + (when (and limit + (> limit 0) + (< limit (length matchings))) + (if (array-has-fill-pointer-p matchings) + (setf (fill-pointer matchings) limit) + (setf matchings (make-array limit :displaced-to matchings)))) + (map-into matchings #'(lambda (m) + (fuzzy-convert-matching-for-emacs m string)) + matchings) + (values matchings interrupted-p))) + + +(defun fuzzy-generate-matchings (string default-package-name time-limit-in-msec) + "Does all the hard work for FUZZY-COMPLETION-SET. If +TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed." + (multiple-value-bind (parsed-symbol-name parsed-package-name package internal-p) + (parse-completion-arguments string default-package-name) + (flet ((fix-up (matchings parent-package-matching) + ;; The components of each matching in MATCHINGS have been computed + ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute. + (let* ((p parent-package-matching) + (p.name (fuzzy-matching.package-name p)) + (p.score (fuzzy-matching.score p)) + (p.chunks (fuzzy-matching.package-chunks p))) + (map-into matchings + #'(lambda (m) + (let ((m.score (fuzzy-matching.score m))) + (setf (fuzzy-matching.package-name m) p.name) + (setf (fuzzy-matching.package-chunks m) p.chunks) + (setf (fuzzy-matching.score m) + (if (equal parsed-symbol-name "") + ;; (Make package matchings be sorted before all the + ;; relative symbol matchings while preserving over + ;; all orderness.) + (/ p.score 100) + (+ p.score m.score))) + m)) + matchings))) + (find-symbols (designator package time-limit &optional filter) + (fuzzy-find-matching-symbols designator package + :time-limit-in-msec time-limit + :external-only (not internal-p) + :filter (or filter #'identity))) + (find-packages (designator time-limit) + (fuzzy-find-matching-packages designator :time-limit-in-msec time-limit))) + (let ((time-limit time-limit-in-msec) (symbols) (packages) (results)) + (cond ((not parsed-package-name) ; E.g. STRING = "asd" + ;; We don't know if user is searching for a package or a symbol + ;; within his current package. So we try to find either. + (setf (values packages time-limit) (find-packages parsed-symbol-name time-limit)) + (setf (values symbols time-limit) (find-symbols parsed-symbol-name package time-limit))) + ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo" + (setf (values symbols time-limit) (find-symbols parsed-symbol-name package time-limit))) + (t ; E.g. STRING = "asd:" or "asd:foo" + ;; Find fuzzy matchings of the denoted package identifier part. + ;; After that, find matchings for the denoted symbol identifier + ;; relative to all the packages found. + (multiple-value-bind (found-packages rest-time-limit) + (find-packages parsed-package-name time-limit-in-msec) + (loop + for package-matching across found-packages + for package = (find-package (fuzzy-matching.package-name package-matching)) + while (or (not time-limit) (> rest-time-limit 0)) do + (multiple-value-bind (matchings remaining-time) + ;; The filter removes all those symbols which are also present + ;; in one of the other packages, specifically if such a package + ;; represents the home package of the symbol, because that one + ;; is deemed to be the best match. + (find-symbols parsed-symbol-name package rest-time-limit + (%make-duplicate-symbols-filter + (remove package-matching found-packages))) + (setf matchings (fix-up matchings package-matching)) + (setf symbols (concatenate 'vector symbols matchings)) + (setf rest-time-limit remaining-time) + (let ((guessed-sort-duration (%guess-sort-duration (length symbols)))) + (when (<= rest-time-limit guessed-sort-duration) + (decf rest-time-limit guessed-sort-duration) + (loop-finish)))) + finally + (setf time-limit rest-time-limit) + (when (equal parsed-symbol-name "") ; E.g. STRING = "asd:" + (setf packages found-packages)))))) + ;; Sort by score; thing with equal score, sort alphabetically. + ;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all possible + ;; completions are to be returned.) + (setf results (concatenate 'vector symbols packages)) + (setf results (sort results #'fuzzy-matching-greaterp)) + (values results (and time-limit (<= time-limit 0))))))) + +(defun %guess-sort-duration (length) + ;; These numbers are pretty much arbitrary, except that they're + ;; vaguely correct on my machine with SBCL. Yes, this is an ugly + ;; kludge, but it's better than before (where this didn't exist at + ;; all, which essentially meant, that this was taken to be 0.) + (if (zerop length) + 0 + (let ((comparasions (* 3.8 (* length (log length 2))))) + (* 1000 (* comparasions (expt 10 -7)))))) ; msecs + +(defun %make-duplicate-symbols-filter (fuzzy-package-matchings) + ;; Returns a filter function that takes a symbol and which returns T + ;; only if no matching in FUZZY-PACKAGE-MATCHINGS represents the + ;; home-package of the. + (let ((packages (mapcar #'(lambda (m) + (find-package (fuzzy-matching.package-name m))) + (coerce fuzzy-package-matchings 'list)))) + #'(lambda (symbol) + (not (member (symbol-package symbol) packages))))) + +(defun fuzzy-matching-greaterp (m1 m2) + "Returns T if fuzzy-matching M1 should be sorted before M2. +Basically just the scores of the two matchings are compared, and +the match with higher score wins. For the case that the score is +equal, the one which comes alphabetically first wins." + (declare (type fuzzy-matching m1 m2)) + (let ((score1 (fuzzy-matching.score m1)) + (score2 (fuzzy-matching.score m2))) + (cond ((> score1 score2) t) + ((< score1 score2) nil) ; total order + (t + (let ((name1 (symbol-name (fuzzy-matching.symbol m1))) + (name2 (symbol-name (fuzzy-matching.symbol m2)))) + (string< name1 name2)))))) + + +(defun get-real-time-in-msecs () + (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000)))) + (values (floor (get-internal-real-time) units-per-msec)))) ; return just one value! + +(defun fuzzy-find-matching-symbols + (string package &key (filter #'identity) external-only time-limit-in-msec) + "Returns two values: a vector of fuzzy matchings for matching +symbols in PACKAGE, using the fuzzy completion algorithm, and the +remaining time limit. + +Only those symbols are considered of which FILTER does return T. + +If EXTERNAL-ONLY is true, only external symbols are considered. A +TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or +negative, perform a NOP." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (package-name (package-name package)) + (count 0)) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type (integer 0 #.(1- most-positive-fixnum)) count)) + + (flet ((recompute-remaining-time (old-remaining-time) + (cond ((not time-limit-p) + (values nil nil)) ; propagate NIL back as infinite time limit. + ((> count 0) ; ease up on getting internal time like crazy. + (setf count (mod (1+ count) 128)) + (values nil old-remaining-time)) + (t (let* ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start)) + (remaining (- time-limit elapsed-time))) + (values (<= remaining 0) remaining))))) + (perform-fuzzy-match (string symbol-name) + (let* ((converter (completion-output-symbol-converter string)) + (converted-symbol-name (funcall converter symbol-name))) + (compute-highest-scoring-completion string converted-symbol-name)))) + (let ((completions (make-array 256 :adjustable t :fill-pointer 0)) + (rest-time-limit time-limit)) + (block loop + (do-symbols* (symbol package) + (multiple-value-bind (exhausted? remaining-time) + (recompute-remaining-time rest-time-limit) + (setf rest-time-limit remaining-time) + (cond (exhausted? (return-from loop)) + ((or (not external-only) (symbol-external-p symbol package)) + (when (funcall filter symbol) + (if (string= "" string) ; "" matches always + (vector-push-extend (make-fuzzy-matching symbol package-name + 0.0 '() '()) + completions) + (multiple-value-bind (match-result score) + (perform-fuzzy-match string (symbol-name symbol)) + (when match-result + (vector-push-extend + (make-fuzzy-matching symbol package-name score + '() match-result) + completions)))))))))) + (values completions rest-time-limit))))) + + +(defun fuzzy-find-matching-packages (name &key time-limit-in-msec) + "Returns a vector of fuzzy matchings for each package that is +similiar to NAME, and the remaining time limit. +Cf. FUZZY-FIND-MATCHING-SYMBOLS." + (let ((time-limit-p (and time-limit-in-msec t)) + (time-limit (or time-limit-in-msec 0)) + (rtime-at-start (get-real-time-in-msecs)) + (converter (completion-output-package-converter name)) + (completions (make-array 32 :adjustable t :fill-pointer 0))) + (declare (type boolean time-limit-p)) + (declare (type integer time-limit rtime-at-start)) + (declare (type function converter)) + (if (and time-limit-p (<= time-limit 0)) + (values #() time-limit) + (loop for package in (list-all-packages) do + ;; Find best-matching package-nickname: + (loop with max-pkg-name = "" + with max-result = nil + with max-score = 0 + for package-name in (package-names package) + for converted-name = (funcall converter package-name) + do + (multiple-value-bind (result score) + (compute-highest-scoring-completion name converted-name) + (when (and result (> score max-score)) + (setf max-pkg-name package-name) + (setf max-result result) + (setf max-score score))) + finally + (when max-result + (vector-push-extend (make-fuzzy-matching nil max-pkg-name + max-score max-result '()) + completions))) + finally + (return + (values completions + (and time-limit-p + (let ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start))) + (- time-limit elapsed-time))))))))) + + +(defslimefun fuzzy-completion-selected (original-string completion) + "This function is called by Slime when a fuzzy completion is +selected by the user. It is for future expansion to make +testing, say, a machine learning algorithm for completion scoring +easier. + +ORIGINAL-STRING is the string the user completed from, and +COMPLETION is the completion object (see docstring for +SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the +user selected." + (declare (ignore original-string completion)) + nil) + + +;;;;; Fuzzy completion core + +(defparameter *fuzzy-recursion-soft-limit* 30 + "This is a soft limit for recursion in +RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit, +completing a string such as "ZZZZZZ" with a symbol named +"ZZZZZZZZZZZZZZZZZZZZZZZ" will result in explosive recursion to +find all the ways it can match. + +Most natural language searches and symbols do not have this +problem -- this is only here as a safeguard.") +(declaim (fixnum *fuzzy-recursion-soft-limit*)) + +(defun compute-highest-scoring-completion (short full) + "Finds the highest scoring way to complete the abbreviation +SHORT onto the string FULL, using CHAR= as a equality function for +letters. Returns two values: The first being the completion +chunks of the highest scorer, and the second being the score." + (let* ((scored-results + (mapcar #'(lambda (result) + (cons (score-completion result short full) result)) + (compute-most-completions short full))) + (winner (first (sort scored-results #'> :key #'first)))) + (values (rest winner) (first winner)))) + +(defun compute-most-completions (short full) + "Finds most possible ways to complete FULL with the letters in SHORT. +Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns +a list of (&rest CHUNKS), where each CHUNKS is a description of +how a completion matches." + (let ((*all-chunks* nil)) + (declare (special *all-chunks*)) + (recursively-compute-most-completions short full 0 0 nil nil nil t) + *all-chunks*)) + +(defun recursively-compute-most-completions + (short full + short-index initial-full-index + chunks current-chunk current-chunk-pos + recurse-p) + "Recursively (if RECURSE-P is true) find /most/ possible ways +to fuzzily map the letters in SHORT onto FULL, using CHAR= to +determine if two letters match. + +A chunk is a list of elements that have matched consecutively. +When consecutive matches stop, it is coerced into a string, +paired with the starting position of the chunk, and pushed onto +CHUNKS. + +Whenever a letter matches, if RECURSE-P is true, +RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position +one index ahead, to find other possibly higher scoring +possibilities. If there are less than +*FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently, +this call will also recurse. + +Once a word has been completely matched, the chunks are pushed +onto the special variable *ALL-CHUNKS* and the function returns." + (declare ;(optimize speed) + (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." + (if (= short-index (length short)) + nil + (aref short short-index))) + (add-to-chunk (char pos) + "Adds the CHAR at POS in FULL to the current chunk, + marking the start position if it is empty." + (unless current-chunk + (setf current-chunk-pos pos)) + (push char current-chunk)) + (collect-chunk () + "Collects the current chunk to CHUNKS and prepares for + a new chunk." + (when current-chunk + (push (list current-chunk-pos + (coerce (reverse current-chunk) 'string)) chunks) + (setf current-chunk nil + current-chunk-pos nil)))) + ;; If there's an outstanding chunk coming in collect it. Since + ;; we're recursively called on skipping an input character, the + ;; chunk can't possibly continue on. + (when current-chunk (collect-chunk)) + (do ((pos initial-full-index (1+ pos))) + ((= pos (length full))) + (let ((cur-char (aref full pos))) + (if (and (short-cur) + (char= cur-char (short-cur))) + (progn + (when recurse-p + ;; Try other possibilities, limiting insanely deep + ;; recursion somewhat. + (recursively-compute-most-completions + short full short-index (1+ pos) + chunks current-chunk current-chunk-pos + (not (> (length *all-chunks*) + *fuzzy-recursion-soft-limit*)))) + (incf short-index) + (add-to-chunk cur-char pos)) + (collect-chunk)))) + (collect-chunk) + ;; If we've exhausted the short characters we have a match. + (if (short-cur) + nil + (let ((rev-chunks (reverse chunks))) + (push rev-chunks *all-chunks*) + rev-chunks)))) + + +;;;;; Fuzzy completion scoring + +(defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<" + "Letters that are likely to be at the beginning of a symbol. +Letters found after one of these prefixes will be scored as if +they were at the beginning of ths symbol.") +(defparameter *fuzzy-completion-symbol-suffixes* "*+->" + "Letters that are likely to be at the end of a symbol. +Letters found before one of these suffixes will be scored as if +they were at the end of the symbol.") +(defparameter *fuzzy-completion-word-separators* "-/." + "Letters that separate different words in symbols. Letters +after one of these symbols will be scores more highly than other +letters.") + +(defun score-completion (completion short full) + "Scores the completion chunks COMPLETION as a completion from +the abbreviation SHORT to the full string FULL. COMPLETION is a +list like: + ((0 "mul") (9 "v") (15 "b")) +Which, if SHORT were "mulvb" and full were "multiple-value-bind", +would indicate that it completed as such (completed letters +capitalized): + MULtiple-Value-Bind + +Letters are given scores based on their position in the string. +Letters at the beginning of a string or after a prefix letter at +the beginning of a string are scored highest. Letters after a +word separator such as #- are scored next highest. Letters at +the end of a string or before a suffix letter at the end of a +string are scored medium, and letters anywhere else are scored +low. + +If a letter is directly after another matched letter, and its +intrinsic value in that position is less than a percentage of the +previous letter's value, it will use that percentage instead. + +Finally, a small scaling factor is applied to favor shorter +matches, all other things being equal." + (labels ((at-beginning-p (pos) + (= pos 0)) + (after-prefix-p (pos) + (and (= pos 1) + (find (aref full 0) *fuzzy-completion-symbol-prefixes*))) + (word-separator-p (pos) + (find (aref full pos) *fuzzy-completion-word-separators*)) + (after-word-separator-p (pos) + (find (aref full (1- pos)) *fuzzy-completion-word-separators*)) + (at-end-p (pos) + (= pos (1- (length full)))) + (before-suffix-p (pos) + (and (= pos (- (length full) 2)) + (find (aref full (1- (length full))) + *fuzzy-completion-symbol-suffixes*))) + (score-or-percentage-of-previous (base-score pos chunk-pos) + (if (zerop chunk-pos) + base-score + (max base-score + (+ (* (score-char (1- pos) (1- chunk-pos)) 0.85) + (expt 1.2 chunk-pos))))) + (score-char (pos chunk-pos) + (score-or-percentage-of-previous + (cond ((at-beginning-p pos) 10) + ((after-prefix-p pos) 10) + ((word-separator-p pos) 1) + ((after-word-separator-p pos) 8) + ((at-end-p pos) 6) + ((before-suffix-p pos) 6) + (t 1)) + pos chunk-pos)) + (score-chunk (chunk) + (loop for chunk-pos below (length (second chunk)) + for pos from (first chunk) + summing (score-char pos chunk-pos)))) + (let* ((chunk-scores (mapcar #'score-chunk completion)) + (length-score (/ 10.0 (1+ (- (length full) (length short)))))) + (values + (+ (reduce #'+ chunk-scores) length-score) + (list (mapcar #'list chunk-scores completion) length-score))))) + +(defun highlight-completion (completion full) + "Given a chunk definition COMPLETION and the string FULL, +HIGHLIGHT-COMPLETION will create a string that demonstrates where +the completion matched in the string. Matches will be +capitalized, while the rest of the string will be lower-case." + (let ((highlit (nstring-downcase (copy-seq full)))) + (dolist (chunk completion) + (setf highlit (nstring-upcase highlit + :start (first chunk) + :end (+ (first chunk) + (length (second chunk)))))) + highlit)) + +(defun format-fuzzy-completion-set (winners) + "Given a list of completion objects such as on returned by +FUZZY-COMPLETION-SET, format the list into user-readable output +for interactive debugging purpose." + (let ((max-len + (loop for winner in winners maximizing (length (first winner))))) + (loop for (sym score result) in winners do + (format t "~&~VA score ~8,2F ~A" + max-len (highlight-completion result sym) score result)))) + +(provide :swank-fuzzy) \ No newline at end of file
Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-listener-hooks.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-listener-hooks.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-listener-hooks.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,82 @@ +;;; swank-listener-hooks.lisp --- listener with special hooks +;; +;; Author: Alan Ruttenberg alanr-l@mumble.net + +;; I guess that only Alan Ruttenberg knows how to use this code. It +;; was in swank.lisp for a long time, so here it is. -- Helmut Eller + +(defvar *slime-repl-advance-history* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from advancing the history - * ** *** etc.") + +(defvar *slime-repl-suppress-output* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from printing the result of the evalation.") + +(defvar *slime-repl-eval-hook-pass* (gensym "PASS") + "Token to indicate that a repl hook declines to evaluate the form") + +(defvar *slime-repl-eval-hooks* nil + "A list of functions. When the repl is about to eval a form, first try running each of + these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass* + is considered a replacement for calling eval. If there are no hooks, or all + pass, then eval is used.") + +(defslimefun repl-eval-hook-pass () + "call when repl hook declines to evaluate the form" + (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*)) + +(defslimefun repl-suppress-output () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from printing the result of the evalation." + (setq *slime-repl-suppress-output* t)) + +(defslimefun repl-suppress-advance-history () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from advancing the history - * ** *** etc." + (setq *slime-repl-advance-history* nil)) + +(defun %eval-region (string) + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (fresh-line) + (finish-output) + (return (values values -))) + (setq - form) + (if *slime-repl-eval-hooks* + (setq values (run-repl-eval-hooks form)) + (setq values (multiple-value-list (eval form)))) + (finish-output)))))) + +(defun run-repl-eval-hooks (form) + (loop for hook in *slime-repl-eval-hooks* + for res = (catch *slime-repl-eval-hook-pass* + (multiple-value-list (funcall hook form))) + until (not (eq res *slime-repl-eval-hook-pass*)) + finally (return + (if (eq res *slime-repl-eval-hook-pass*) + (multiple-value-list (eval form)) + res)))) + +(defun %listener-eval (string) + (clear-user-input) + (with-buffer-syntax () + (track-package + (lambda () + (let ((*slime-repl-suppress-output* :unset) + (*slime-repl-advance-history* :unset)) + (multiple-value-bind (values last-form) (%eval-region string) + (unless (or (and (eq values nil) (eq last-form nil)) + (eq *slime-repl-advance-history* nil)) + (setq *** ** ** * * (car values) + /// // // / / values)) + (setq +++ ++ ++ + + last-form) + (unless (eq *slime-repl-suppress-output* t) + (funcall *send-repl-results-function* values)))))))) + +(setq *listener-eval-function* '%listener-eval) + +(provide :swank-listener-hooks)
Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,319 @@ +;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities +;;; to portions of output +;;; +;;; Authors: Alan Ruttenberg alanr-l@mumble.net +;;; Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de +;;; Helmut Eller heller@common-lisp.net +;;; +;;; License: This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(in-package :swank) + +(swank-require :swank-presentations) + +;; This file contains a mechanism for printing to the slime repl so +;; that the printed result remembers what object it is associated +;; with. This extends the recording of REPL results. +;; +;; There are two methods: +;; +;; 1. Depends on the ilisp bridge code being installed and ready to +;; intercept messages in the printed stream. We encode the +;; information with a message saying that we are starting to print +;; an object corresponding to a given id and another when we are +;; done. The process filter notices these and adds the necessary +;; text properties to the output. +;; +;; 2. Use separate protocol messages :presentation-start and +;; :presentation-end for sending presentations. +;; +;; We only do this if we know we are printing to a slime stream, +;; checked with the method slime-stream-p. Initially this checks for +;; the knows slime streams looking at *connections*. In cmucl, sbcl, and +;; openmcl it also checks if it is a pretty-printing stream which +;; ultimately prints to a slime stream. +;; +;; Method 1 seems to be faster, but the printed escape sequences can +;; disturb the column counting, and thus the layout in pretty-printing. +;; We use method 1 when a dedicated output stream is used. +;; +;; Method 2 is cleaner and works with pretty printing if the pretty +;; printers support "annotations". We use method 2 when no dedicated +;; output stream is used. + +;; Control +(defvar *enable-presenting-readable-objects* t + "set this to enable automatically printing presentations for some +subset of readable objects, such as pathnames." ) + +;; doing it + +(defmacro presenting-object (object stream &body body) + "What you use in your code. Wrap this around some printing and that text will +be sensitive and remember what object it is in the repl" + `(presenting-object-1 ,object ,stream #'(lambda () ,@body))) + +(defmacro presenting-object-if (predicate object stream &body body) + "What you use in your code. Wrap this around some printing and that text will +be sensitive and remember what object it is in the repl if predicate is true" + (let ((continue (gensym))) + `(let ((,continue #'(lambda () ,@body))) + (if ,predicate + (presenting-object-1 ,object ,stream ,continue) + (funcall ,continue))))) + +;;; Get pretty printer patches for SBCL at load (not compile) time. +#+sbcl +(eval-when (:load-toplevel) + (handler-bind ((simple-error + (lambda (c) + (declare (ignore c)) + (let ((clobber-it (find-restart 'sb-kernel::clobber-it))) + (when clobber-it (invoke-restart clobber-it)))))) + (sb-ext:without-package-locks + (swank-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)) + (defun slime-stream-p (stream) + "Check if stream is one of the slime streams, since if it isn't we +don't want to present anything. +Two special return values: +:DEDICATED -- Output ends up on a dedicated output stream +:REPL-RESULT -- Output ends up on the :repl-results target. +" + (if (eq last-stream stream) + last-answer + (progn + (setq last-stream stream) + (if (eq stream t) + (setq stream *standard-output*)) + (setq last-answer + (or #+openmcl + (and (typep stream 'ccl::xp-stream) + ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) + (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) + #+cmu + (or (and (typep stream 'lisp::indenting-stream) + (slime-stream-p (lisp::indenting-stream-stream stream))) + (and (typep stream 'pretty-print::pretty-stream) + (fboundp 'pretty-print::enqueue-annotation) + (let ((slime-stream-p + (slime-stream-p (pretty-print::pretty-stream-target stream)))) + (and ;; Printing through CMUCL pretty + ;; streams is only cleanly + ;; possible if we are using the + ;; bridge-less protocol with + ;; annotations, because the bridge + ;; escape sequences disturb the + ;; pretty printer layout. + (not (eql slime-stream-p :dedicated-output)) + ;; If OK, return the return value + ;; we got from slime-stream-p on + ;; the target stream (could be + ;; :repl-result): + slime-stream-p)))) + #+sbcl + (let () + (declare (notinline sb-pretty::pretty-stream-target)) + (or (and (typep stream 'sb-impl::indenting-stream) + (slime-stream-p (sb-impl::indenting-stream-stream stream))) + (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)) + (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty) + (not *use-dedicated-output-stream*) + (slime-stream-p (sb-pretty::pretty-stream-target stream))))) + #+allegro + (and (typep stream 'excl:xp-simple-stream) + (slime-stream-p (excl::stream-output-handle stream))) + (loop for connection in *connections* + thereis (or (and (eq stream (connection.dedicated-output connection)) + :dedicated) + (eq stream (connection.socket-io connection)) + (eq stream (connection.user-output connection)) + (eq stream (connection.user-io connection)) + (and (eq stream (connection.repl-results connection)) + :repl-result))))))))) + +(defun can-present-readable-objects (&optional stream) + (declare (ignore stream)) + *enable-presenting-readable-objects*) + +;; If we are printing to an XP (pretty printing) stream, printing the +;; escape sequences directly would mess up the layout because column +;; counting is disturbed. Use "annotations" instead. +#+allegro +(defun write-annotation (stream function arg) + (if (typep stream 'excl:xp-simple-stream) + (excl::schedule-annotation stream function arg) + (funcall function arg stream nil))) +#+cmu +(defun write-annotation (stream function arg) + (if (and (typep stream 'pp:pretty-stream) + (fboundp 'pp::enqueue-annotation)) + (pp::enqueue-annotation stream function arg) + (funcall function arg stream nil))) +#+sbcl +(defun write-annotation (stream function arg) + (let ((enqueue-annotation + (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty))) + (if (and enqueue-annotation + (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))) + (funcall enqueue-annotation stream function arg) + (funcall function arg stream nil)))) +#-(or allegro cmu sbcl) +(defun write-annotation (stream function arg) + (funcall function arg stream nil)) + +(defstruct presentation-record + (id) + (printed-p) + (target)) + +(defun presentation-start (record stream truncatep) + (unless truncatep + ;; Don't start new presentations when nothing is going to be + ;; printed due to *print-lines*. + (let ((pid (presentation-record-id record)) + (target (presentation-record-target record))) + (case target + (:dedicated + ;; Use bridge protocol + (write-string "<" stream) + (prin1 pid stream) + (write-string " " stream)) + (t + (finish-output stream) + (send-to-emacs `(:presentation-start ,pid ,target))))) + (setf (presentation-record-printed-p record) t))) + +(defun presentation-end (record stream truncatep) + (declare (ignore truncatep)) + ;; Always end old presentations that were started. + (when (presentation-record-printed-p record) + (let ((pid (presentation-record-id record)) + (target (presentation-record-target record))) + (case target + (:dedicated + ;; Use bridge protocol + (write-string ">" stream) + (prin1 pid stream) + (write-string " " stream)) + (t + (finish-output stream) + (send-to-emacs `(:presentation-end ,pid ,target))))))) + +(defun presenting-object-1 (object stream continue) + "Uses the bridge mechanism with two messages >id and <id. The first one +says that I am starting to print an object with this id. The second says I am finished" + (let ((slime-stream-p + (and *record-repl-results* (slime-stream-p stream)))) + (if slime-stream-p + (let* ((pid (swank::save-presented-object object)) + (record (make-presentation-record :id pid :printed-p nil + :target (if (eq slime-stream-p :repl-result) + :repl-result + nil)))) + (write-annotation stream #'presentation-start record) + (multiple-value-prog1 + (funcall continue) + (write-annotation stream #'presentation-end record))) + (funcall continue)))) + +(defun present-repl-results-via-presentation-streams (values) + ;; Override a function in swank.lisp, so that + ;; nested presentations work in the REPL result. + (let ((repl-results (connection.repl-results *emacs-connection*))) + (flet ((send (value) + (presenting-object value repl-results + (prin1 value repl-results)) + (terpri repl-results))) + (if (null values) + (progn + (princ "; No value" repl-results) + (terpri repl-results)) + (mapc #'send values))) + (finish-output repl-results))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Example: Tell openmcl and cmucl to always present unreadable objects. try (describe 'class) +#+openmcl +(in-package :ccl) +#+openmcl +(let ((*warn-if-redefine-kernel* nil) + (*warn-if-redefine* nil)) + (defun %print-unreadable-object (object stream type id thunk) + (cond ((null stream) (setq stream *standard-output*)) + ((eq stream t) (setq stream *terminal-io*))) + (swank::presenting-object object stream + (write-unreadable-start object stream) + (when type + (princ (type-of object) stream) + (stream-write-char stream #\space)) + (when thunk + (funcall thunk)) + (if id + (%write-address object stream #>) + (pp-end-block stream ">")) + nil)) + (defmethod print-object :around ((pathname pathname) stream) + (swank::presenting-object-if + (swank::can-present-readable-objects stream) + pathname stream (call-next-method)))) + +#+openmcl +(ccl::def-load-pointers clear-presentations () + (swank::clear-presentation-tables)) + +(in-package :swank) + +#+cmu +(progn + (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body) + (presenting-object object stream + (fwrappers:call-next-function))) + + (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (fwrappers:call-next-function))) + + (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper) + (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper) + ) + +#+sbcl +(progn + (defvar *saved-%print-unreadable-object* + (fdefinition 'sb-impl::%print-unreadable-object)) + (sb-ext:without-package-locks + (setf (fdefinition 'sb-impl::%print-unreadable-object) + (lambda (object stream type identity body) + (presenting-object object stream + (funcall *saved-%print-unreadable-object* + object stream type identity body)))) + (defmethod print-object :around ((object pathname) stream) + (presenting-object object stream + (call-next-method))))) + +#+allegro +(progn + (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation) + (swank::presenting-object object stream (excl:call-next-fwrapper))) + (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (excl:call-next-fwrapper))) + (excl:fwrap 'excl::print-unreadable-object-1 + 'print-unreadable-present 'presenting-unreadable-wrapper) + (excl:fwrap 'excl::pathname-printer + 'print-pathname-present 'presenting-pathname-wrapper)) + +;; Hook into SWANK. + +(setq *send-repl-results-function* 'present-repl-results-via-presentation-streams) + +(provide :swank-presentation-streams)
Added: branches/trunk-reorg/thirdparty/slime/contrib/swank-presentations.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-presentations.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-presentations.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,235 @@ +;;; swank-presentations.lisp --- imitate LispM's presentations +;; +;; Authors: Alan Ruttenberg alanr-l@mumble.net +;; Luke Gorrie luke@synap.se +;; Helmut Eller heller@common-lisp.net +;; Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de +;; +;; License: This code has been placed in the Public Domain. All warranties +;; are disclaimed. +;; + +(in-package :swank) + +;;;; 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 thread-id frame index) + (declare (ignore thread-id)) ; later + (handler-case + (frame-var-value frame index) + (t (condition) + (declare (ignore condition)) + (values nil nil)) + (:no-error (value) + (values value t)))) + ((:inspected-part part-index) + (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 (error "Attempt to access unrecorded object (id ~D)." id))))) + +(defslimefun clear-repl-results () + "Forget the results of all previous REPL evaluations." + (clear-presentation-tables) + t) + +(defun present-repl-results (values) + ;; Override a function in swank.lisp, so that + ;; presentations are associated with every REPL result. + (flet ((send (value) + (let ((id (and *record-repl-results* + (save-presented-object value)))) + (send-to-emacs `(:presentation-start ,id :repl-result)) + (send-to-emacs `(:write-string ,(prin1-to-string value) + :repl-result)) + (send-to-emacs `(:presentation-end ,id :repl-result)) + (send-to-emacs `(:write-string ,(string #\Newline) + :repl-result))))) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (mapc #'send values)))) + + +;;;; Presentation menu protocol +;; +;; To define a menu for a type of object, define a method +;; menu-choices-for-presentation on that object type. This function +;; should return a list of two element lists where the first element is +;; the name of the menu action and the second is a function that will be +;; called if the menu is chosen. The function will be called with 3 +;; arguments: +;; +;; choice: The string naming the action from above +;; +;; object: The object +;; +;; id: The presentation id of the object +;; +;; You might want append (when (next-method-p) (call-next-method)) to +;; pick up the Menu actions of superclasses. +;; + +(defvar *presentation-active-menu* nil) + +(defun menu-choices-for-presentation-id (id) + (multiple-value-bind (ob presentp) (lookup-presented-object id) + (cond ((not presentp) 'not-present) + (t + (let ((menu-and-actions (menu-choices-for-presentation ob))) + (setq *presentation-active-menu* (cons id menu-and-actions)) + (mapcar 'car menu-and-actions)))))) + +(defun swank-ioify (thing) + (cond ((keywordp thing) thing) + ((and (symbolp thing)(not (find #: (symbol-name thing)))) + (intern (symbol-name thing) 'swank-io-package)) + ((consp thing) (cons (swank-ioify (car thing)) (swank-ioify (cdr thing)))) + (t thing))) + +(defun execute-menu-choice-for-presentation-id (id count item) + (let ((ob (lookup-presented-object id))) + (assert (equal id (car *presentation-active-menu*)) () + "Bug: Execute menu call for id ~a but menu has id ~a" + id (car *presentation-active-menu*)) + (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) + (swank-ioify (funcall action item ob id))))) + + +(defgeneric menu-choices-for-presentation (object) + (:method (ob) (declare (ignore ob)) nil)) ; default method + +;; Pathname +(defmethod menu-choices-for-presentation ((ob pathname)) + (let* ((file-exists (ignore-errors (probe-file ob))) + (lisp-type (make-pathname :type "lisp")) + (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal)) + (let ((source (merge-pathnames lisp-type ob))) + (and (ignore-errors (probe-file source)) + source)))) + (fasl-file (and file-exists + (equal (ignore-errors + (namestring + (truename + (compile-file-pathname + (merge-pathnames lisp-type ob))))) + (namestring (truename ob)))))) + (remove nil + (list* + (and (and file-exists (not fasl-file)) + (list "Edit this file" + (lambda(choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring (truename object))) + nil))) + (and file-exists + (list "Dired containing directory" + (lambda (choice object id) + (declare (ignore choice id)) + (ed-in-emacs (namestring + (truename + (merge-pathnames + (make-pathname :name "" :type "") object)))) + nil))) + (and fasl-file + (list "Load this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (load ob) + nil))) + (and fasl-file + (list "Delete this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (let ((nt (namestring (truename ob)))) + (when (y-or-n-p-in-emacs "Delete ~a? " nt) + (delete-file nt))) + nil))) + (and source-file + (list "Edit lisp source file" + (lambda (choice object id) + (declare (ignore choice id object)) + (ed-in-emacs (namestring (truename source-file))) + nil))) + (and source-file + (list "Load lisp source file" + (lambda(choice object id) + (declare (ignore choice id object)) + (load source-file) + nil))) + (and (next-method-p) (call-next-method)))))) + +(defmethod menu-choices-for-presentation ((ob function)) + (list (list "Disassemble" + (lambda (choice object id) + (declare (ignore choice id)) + (disassemble object))))) + +(defslimefun inspect-presentation (id reset-p) + (let ((what (lookup-presented-object id))) + (when reset-p + (reset-inspector)) + (inspect-object what))) + + +(setq *send-repl-results-function* 'present-repl-results) + +(provide :swank-presentations)
Added: branches/trunk-reorg/thirdparty/slime/doc/.cvsignore =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/.cvsignore 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/.cvsignore 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,15 @@ +contributors.texi +slime.aux +slime.cp +slime.dvi +slime.fn +slime.info +slime.ky +slime.log +slime.pdf +slime.pg +slime.ps +slime.tmp +slime.toc +slime.tp +slime.vr
Added: branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,9 @@ +/.cvsignore/1.1/Mon Jul 24 14:13:23 2006// +/Makefile/1.12/Mon Sep 17 14:04:27 2007// +/slime-refcard.pdf/1.1/Thu Aug 9 09:18:50 2007// +/slime-refcard.tex/1.1/Thu Aug 9 09:18:50 2007// +/slime-small.eps/1.1/Wed Nov 22 06:27:38 2006// +/slime-small.pdf/1.1/Wed Nov 22 06:27:38 2006// +/slime.texi/1.57/Mon Sep 17 13:44:48 2007// +/texinfo-tabulate.awk/1.2/Mon Aug 29 20:02:57 2005// +D
Added: branches/trunk-reorg/thirdparty/slime/doc/CVS/Repository =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/CVS/Repository 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/CVS/Repository 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +slime/doc
Added: branches/trunk-reorg/thirdparty/slime/doc/CVS/Root =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/CVS/Root 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/CVS/Root 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1 @@ +:pserver:anonymous:anonymous@common-lisp.net:/project/slime/cvsroot
Added: branches/trunk-reorg/thirdparty/slime/doc/CVS/Template ===================================================================
Added: branches/trunk-reorg/thirdparty/slime/doc/Makefile =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/Makefile 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/Makefile 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,97 @@ +# 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 +# /usr/local/share/info. Many distros obey the FHS, but people who +# installed their emacs from source probably have a GCS-ish file +# hierarchy. +infodir=/usr/local/info + +# What command to use to install info file(s) +INSTALL_CMD=install -m 644 + +# Info files generated here. +infofiles=slime.info + +TEXI = slime.texi contributors.texi + +all: slime.info slime.pdf html/index.html + +slime.dvi: $(TEXI) + texi2dvi slime.texi + +slime.ps: slime.dvi + dvips -o $@ $< + +slime.info: $(TEXI) + makeinfo $< + +slime.html: $(TEXI) + texi2html $< + +html/index.html: $(TEXI) + makeinfo -o html --html $< + +slime.pdf: $(TEXI) + texi2pdf $< + +install: install-info + +uninstall: uninstall-info + +# Create contributors.texi, a texinfo table listing all known +# contributors of code. +# +# Explicitly includes Eric Marsden (pre-ChangeLog hacker) +# +# The gist of this horror show is that the contributor list is piped +# into texinfo-tabulate.awk with one name per line, sorted +# alphabetically. +# +# Some special-case TeX-escaping of international characters. +contributors.texi: ../ChangeLog Makefile texinfo-tabulate.awk + cat ../ChangeLog | \ + sed -ne '/^[0-9]/{s/^[^ ]* *//; s/ *<.*//; p;}' | \ + sort | \ + uniq -c | \ + sort -nr| \ + sed -e 's/^[^A-Z]*//' | \ + awk -f texinfo-tabulate.awk | \ + 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 + +# Debian's install-info wants a --section argument. +section := $(shell grep INFO-DIR-SECTION $(infofiles) | sed 's/INFO-DIR-SECTION //') +install-info: slime.info + mkdir -p $(infodir) + $(INSTALL_CMD) $(infofiles) $(infodir)/$(infofiles) + @if (install-info --version && \ + install-info --version 2>&1 | sed 1q | grep -i -v debian) >/dev/null 2>&1; then \ + echo "install-info --info-dir=$(infodir) $(infodir)/$(infofiles)";\ + install-info --info-dir="$(infodir)" "$(infodir)/$(infofiles)" || :;\ + else \ + echo "install-info --infodir=$(infodir) --section $(section) $(section) $(infodir)/$(infofiles)" && \ + install-info --infodir="$(infodir)" --section $(section) ${section} "$(infodir)/$(infofiles)" || :; fi + +uninstall-info: + @if (install-info --version && \ + install-info --version 2>&1 | sed 1q | grep -i -v debian) >/dev/null 2>&1; then \ + echo "install-info --info-dir=$(infodir) --remove $(infodir)/$(infofiles)";\ + install-info --info-dir="$(infodir)" --remove "$(infodir)/$(infofiles)" || :;\ + else \ + echo "install-info --infodir=$(infodir) --remove $(infodir)/$(infofiles)";\ + install-info --infodir="$(infodir)" --remove "$(infodir)/$(infofiles)" || :; fi + rm -f $(infodir)/$(infofiles) + +clean: + rm -f contributors.texi + rm -f slime.{aux,cp,cps,fn,fns,ky,kys,log,pg,tmp,toc,tp,vr,vrs} + rm -f slime.{info,pdf,dvi,ps,html} + rm -rf html
Added: branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.pdf =================================================================== (Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.pdf ___________________________________________________________________ Name: svn:mime-type + application/octet-stream
Added: branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.tex =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.tex 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/slime-refcard.tex 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,123 @@ +\documentclass[a4paper,10pt]{article} + +\usepackage{textcomp} +\usepackage{fullpage} +\pagestyle{empty} + + +\newcommand{\group}[1]{\bigskip\par\noindent\textbf{\large#1}\medskip} +\newcommand{\subgroup}[1]{\medskip\par\noindent\textbf{#1}\smallskip} +\newcommand{\key}[2]{\par\noindent\textbf{#1}\hfill{#2}} +\newcommand{\meta}[1]{\textlangle{#1}\textrangle} + +\begin{document} + +\twocolumn[\LARGE\centering{SLIME Quick Reference Card}\vskip1cm] + +\group{Getting help in Emacs} + +\key{C-h \meta{key}}{describe function bound to \meta{key}} +\key{C-h b}{list the current key-bindings for the focus buffer} +\key{C-h m}{describe mode} +\key{C-h l}{shows the keys you have pressed} +\key{\meta{key} l}{what starts with \meta{key}} + +\group{Programming} + +\subgroup{Completion} + +\key{M-tab, C-c C-i, C-M-i}{complete symbol} +\key{C-c C-s}{complete form} +\key{C-c M-i}{fuzzy complete symbol} + +\subgroup{Closure} + +\key{C-c C-q}{close parens at point} +\key{C-]}{cl}{close all sexp} + +\subgroup{Indentation} + +\key{C-c M-q}{reindent defun} +\key{C-M-q}{indent sexp} + +\subgroup{Documentation} + +\key{spc}{insert a space, display argument list} +\key{C-c C-d d}{describe symbol} +\key{C-c C-f}{describe function} +\key{C-c C-d a}{apropos search for regexp} +\key{C-c C-d z}{apropos with internal symbols} +\key{C-c C-d p}{apropos in package} +\key{C-c C-d h}{hyperspec lookup} +\key{C-c C-d ~}{format character hyperspec lookup} + + +\subgroup{Cross reference} + +\key{C-c C-w c}{show function callers} +\key{C-c C-w r}{show references to global variable} +\key{C-c C-w b}{show bindings of a global variable} +\key{C-c C-w s}{show assignments to a global variable} +\key{C-c C-w m}{show expansions of a macro} +\key{C-c \textless}{list callers of a function} +\key{C-c \textgreater}{list callees of a function} + +\subgroup{Finding definitions} + +\key{M-.}{edit definition} +\key{M-, or M-*}{pop definition stack} +\key{C-x 4 .}{edit definition in other window} +\key{C-x 5 .}{edit definition in other frame} + +\newpage + +\subgroup{Macro expansion commands} + +\key{C-c C-m or C-c RET}{macroexpand-1} +\key{C-c C-m}{macroexpand-all} +\key{C-c C-t}{toggle tracing of the function at point} + +\subgroup{Disassembly} + +\key{C-c M-d}{disassemble function definition} + +\group{Compilation} + +\key{C-c C-c}{compile defun} +\key{C-c C-y}{call defun} +\key{C-c C-k}{compile and load file} +\key{C-c M-k}{compile file} +\key{C-c C-l}{load file} +\key{C-c C-z}{switch to output buffer} +\key{M-n}{next note} +\key{M-p}{previous note} +\key{C-c M-c}{remove notes} + +\group{Evaluation} + +\key{C-M-x}{eval defun} +\key{C-x C-e}{eval last expression} +\key{C-c C-p}{eval & pretty print last expression} +\key{C-c C-r}{eval region} +\key{C-x M-e}{eval last expression, display output} +\key{C-c :}{interactive eval} +\key{C-c E}{edit value} +\key{C-c C-u}{undefine function} + +\group{Abort/Recovery} + +\key{C-c C-b}{interrupt (send SIGINT)} +\key{C-c ~}{sync the current package and working directory} +\key{C-c M-p}{set package in REPL} + +\group{Inspector} + +\key{C-c I}{inspect (from minibuffer)} +\key{ret}{operate on point} +\key{d}{describe} +\key{l}{pop} +\key{n}{next} +\key{q}{quit} +\key{M-ret}{copy down} + +\end{document}
Added: branches/trunk-reorg/thirdparty/slime/doc/slime-small.eps =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/slime-small.eps 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/slime-small.eps 2007-10-04 17:23:45 UTC (rev 2200) @@ -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$%_\AdCOF21uK7NrKs+: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@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@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@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!@]$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@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@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@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@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@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@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@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@#&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#hWEqo: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@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@$=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,!<<&@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^@(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@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@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@K6.%l!/(1K*WCV=GK=BRM5O]lD"RZ*s3Ph-Deirn +AS?gq%:5blO1bA%S)`X(,o6qYp'cJ,~> +nGa$Yb0'b`aiMZk_SEk,_7@#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@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 +s7hJrt: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 +s7hJrt: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@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)WhlF8l4F8u7AF8u: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@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@-=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@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: branches/trunk-reorg/thirdparty/slime/doc/slime-small.pdf =================================================================== (Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/slime/doc/slime-small.pdf ___________________________________________________________________ Name: svn:mime-type + application/octet-stream
Added: branches/trunk-reorg/thirdparty/slime/doc/slime.texi =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/slime.texi 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/slime.texi 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,2471 @@ +\input texinfo +-@c %**start of header +@setfilename slime.info +@settitle The Superior Lisp Interaction Mode for Emacs + +@dircategory Emacs +@direntry +* SLIME: (slime). Superior Lisp Interaction Mode for Emacs. +@end direntry +-@c %**end of header + +@set EDITION 3.0-alpha +@set SLIMEVER 3.0-alpha +@c @set UPDATED @today{} +@set UPDATED @code{$Date: 2007/09/17 13:44:48 $} +@set TITLE SLIME User Manual +@settitle @value{TITLE}, version @value{EDITION} + +@copying +Written by Luke Gorrie. + +Additional contributions: Jeff Cunningham, + +This file has been placed in the public domain. +@end copying + +@titlepage +@title @value{TITLE} +@titlefont{version @value{EDITION}} +@sp 2 +@center @image{slime-small} +@sp 4 +@subtitle Compiled: @value{UPDATED} + +@page +@insertcopying + +@end titlepage + + +@macro SLIME +@acronym{SLIME} +@end macro + +@macro SLDB +@acronym{SLDB} +@end macro + +@macro REPL +@acronym{REPL} +@end macro + +@macro CVS +@acronym{CVS} +@end macro + +@macro kbditem{key, command} +@item \key\ +@itemx M-x \command\ +@kindex \key\ +@findex \command\ +@c +@end macro + +@macro kbditempair{key1, key2, command1, command2} +@item \key1, M-x \command1\ +@itemx \key2, M-x \command2\ +@kindex \key1\ +@kindex \key2\ +@findex \command1\ +@findex \command2\ +@c +@end macro + +@macro cmditem{command} +@item M-x \command\ +@findex \command\ +@c +@end macro + +@macro kbdanchorc{key, command, comment} +@anchor{\command} +@item \key\ +@code{\command} +@i{\comment}@* +@end macro + +@macro fcnindex{name} +@item \name\ +@xref{\name}. +@end macro + +@c @setchapternewpage off +@c @shortcontents +@contents + +@ifnottex +@node Top +@top SLIME + +@SLIME{} is the ``Superior Lisp Interaction Mode for Emacs''. This is +the manual for version @value{SLIMEVER}. + +@insertcopying +@end ifnottex + +@menu +* Introduction:: +* Getting started:: +* slime-mode:: +* REPL:: +* Debugger:: +* Extras:: +* Customization:: +* Tips and Tricks:: +* Credits:: +@c * Index to Functions:: +* Key Index:: +* Command Index:: +* Variable Index:: +@end menu + +@c ----------------------- +@node Introduction +@chapter Introduction + +@SLIME{} is the ``Superior Lisp Interaction Mode for Emacs.'' + +@SLIME{} extends Emacs with support for interactive programming in +Common Lisp. The features are centered around @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 +compilation, debugging, documentation lookup, and so on. + +The @code{slime-mode} programming environment follows the example of +Emacs's native Emacs Lisp environment. We have also included good +ideas from similar systems (such as @acronym{ILISP}) and some new +ideas of our own. + +@SLIME{} is constructed from two parts: a user-interface written in +Emacs Lisp, and a supporting server program written in Common +Lisp. The two sides are connected together with a socket and +communicate using an @acronym{RPC}-like protocol. + +The Lisp server is primarily written in portable Common Lisp. The +required implementation-specific functionality is specified by a +well-defined interface and implemented separately for each Lisp +implementation. This makes @SLIME{} readily portable. + +@c ----------------------- +@node Getting started +@chapter Getting started + +This chapter tells you how to get @SLIME{} up and running. + +@menu +* Platforms:: +* Downloading:: +* Installation:: +* Running:: +* Setup Tuning:: +@end menu + +@c ----------------------- +@node Platforms +@section Supported Platforms + +@SLIME{} supports a wide range of operating systems and Lisp +implementations. @SLIME{} runs on Unix systems, Mac OSX, and Microsoft +Windows. GNU Emacs versions 20, 21 and 22 and XEmacs version 21 are +supported. + +The supported Lisp implementations, roughly ordered from the +best-supported, are: + +@itemize @bullet +@item +CMU Common Lisp (@acronym{CMUCL}), 19d or newer +@item +Steel Bank Common Lisp (@acronym{SBCL}), 1.0 or newer +@item +OpenMCL, version 0.14.3 or newer +@item +LispWorks, version 4.3 or newer +@item +Allegro Common Lisp (@acronym{ACL}), version 6 or newer +@item +@acronym{CLISP}, version 2.35 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%7D) +@item +Scieneer Common Lisp (@acronym{SCL}), version 1.2.7 or newer +@end itemize + +Most features work uniformly across implementations, but some are +prone to variation. These include the precision of placing +compiler-note annotations, @acronym{XREF} support, and fancy debugger +commands (like ``restart frame''). + +@c ----------------------- +@node Downloading +@section Downloading SLIME + +You can choose between using a released version of @SLIME{} or +accessing our @CVS{} repository directly. You can download the latest +released version from our website: + +@url{http://www.common-lisp.net/project/slime/%7D + +We recommend that users who participate in the @code{slime-devel} +mailing list use the @CVS{} version of the code. + +@menu +* CVS:: +* CVS Incantations:: +@end menu + +@c ----------------------- +@node CVS +@subsection Downloading from CVS + +@SLIME{} is available from the @CVS{} repository on +@file{common-lisp.net}. You have the option to use either the very +latest code or the tagged @code{FAIRLY-STABLE} snapshot. + +The latest version tends to have more features and fewer bugs than the +@code{FAIRLY-STABLE} version, but it can be unstable during times of +major surgery. As a rule-of-thumb recommendation we suggest that if +you follow the @code{slime-devel} mailing list then you're better off +with the latest version (we'll send a note when it's undergoing major +hacking). If you don't follow the mailing list you won't know the +status of the latest code, so tracking @code{FAIRLY-STABLE} or using a +released version is the safe option. + +If you checkout from @CVS{} then remember to @code{cvs update} +occasionally. Improvements are continually being committed, and the +@code{FAIRLY-STABLE} tag is moved forward from time to time. + +@menu +* CVS Incantations:: +@end menu + +@c ----------------------- +@node CVS Incantations +@subsection CVS incantations + +To download @SLIME{} you first configure your @code{CVSROOT} and login +to the repository. + +@example +export CVSROOT=:pserver:anonymous@@common-lisp.net:/project/slime/cvsroot +cvs login +@end example +@emph{(The password is @code{anonymous})} + +The latest version can then be checked out with: +@example +cvs checkout slime +@end example + +Or the @code{FAIRLY-STABLE} version can be checked out with: + +@example +cvs checkout -rFAIRLY-STABLE slime +@end example + +If you want to find out what's new since the version you're currently +running, you can diff the local @file{ChangeLog} against the +repository version: + +@example +cvs diff -rHEAD ChangeLog # or: -rFAIRLY-STABLE +@end example + +@c ----------------------- +@node Installation +@section Installation + +With a Lisp implementation that can be started from the command-line, +installation just requires a few lines in your @file{~/.emacs}: + +@vindex inferior-lisp-program +@vindex load-path +@example +(setq inferior-lisp-program "@emph{the path to your Lisp system}") +(add-to-list 'load-path "@emph{the path of your @file{slime} directory}") +(require 'slime) +(slime-setup) +@end example + +@iftex +The snippet above also appears in the @file{README} file. You can +copy&paste it from there, but remember to fill in the appropriate +paths. +@end iftex + +We recommend not loading the @acronym{ILISP} package into Emacs if you +intend to use @SLIME{}. Doing so will add a lot of extra bindings to +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 +@section Running SLIME + +@SLIME{} is started with the Emacs command @kbd{M-x slime}. This uses +the @code{inferior-lisp} package to start a Lisp process, loads and +starts the Lisp-side server (known as ``Swank''), and establishes a +socket connection between Emacs and Lisp. Finally a @REPL{} buffer is +created where you can enter Lisp expressions for evaluation. + +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 +@cmditem{slime-restart-inferior-lisp} +@end table + +@node Setup Tuning +@section Setup Tuning + +This section explains ways to reduce @SLIME{}'s startup time and how +to configure @SLIME{} for multiple Lisp systems. + +Please proceed with this section only if your basic setup works. If +you are happy with the basic setup, skip this section. + +@menu +* Autoloading:: +* Multiple Lisps:: +* Loading Swank faster:: +* Loading Contribs:: +@end menu + +@node Autoloading +@subsection Autoloading + +The basic setup loads @SLIME{} always, even if you don't use @SLIME{}. +Emacs will start up a little faster if we load @SLIME{} only on +demand. To achieve that, you have to change your @file{~/.emacs} +slightly: + +@example +(setq inferior-lisp-program "@emph{the path to your Lisp system}") +(add-to-list 'load-path "@emph{the path of your @file{slime} directory}") +(require 'slime-autoloads) +(slime-setup) +@end example + +The only difference compared to the basic setup is the line +@code{(require 'slime-autoloads)}. It tells Emacs that the rest of +@SLIME{} should be loaded when one of the commands @kbd{M-x slime} or +@kbd{M-x slime-connect} is executed the first time. + +@node Multiple Lisps +@subsection Multiple Lisps + +By default, the command @kbd{M-x slime} starts the program specified +with @code{inferior-lisp-program}. If you invoke @kbd{M-x slime} with +a prefix argument, Emacs prompts for the program which should be +started instead. If you need that frequently or if the command +involves long filenames it's more convenient to set the +@code{slime-lisp-implementations} variable in your @file{.emacs}. For +example here we define two programs: + +@vindex slime-lisp-implementations +@lisp +(setq slime-lisp-implementations + '((cmucl ("cmucl" "-quiet")) + (sbcl ("/opt/sbcl/bin/sbcl") :coding-system utf-8-unix))) +@end lisp + +This variable holds a list of programs and if you invoke @SLIME{} with +a negative prefix argument, @kbd{M-- M-x slime}, you can select a +program from that list. The elements of the list should look like + +@lisp +(NAME (PROGRAM PROGRAM-ARGS...) &key CODING-SYSTEM INIT INIT-FUNCTION) +@end lisp + +@table @code +@item NAME +is a symbol and is used to identify the program. +@item PROGRAM +is the filename of the program. Note that the filename can contain +spaces. +@item PROGRAM-ARGS +is a list of command line arguments. +@item CODING-SYSTEM +the coding system for the connection. +@item INIT +@itemx INIT-FUNCTION + ... to be written ... +@end table + +@node Loading Swank faster +@subsection Loading Swank faster + +For SBCL, we recommend that you create a custom core file with socket +support and @acronym{POSIX} bindings included because those modules +take the most time to load. To create such a core, execute the +following steps: + +@example +shell$ sbcl +* (mapc 'require '(sb-bsd-sockets sb-posix sb-introspect sb-cltl2 asdf)) +* (save-lisp-and-die "sbcl.core-for-slime") +@end example + +After that, add something like this to your @file{.emacs}: + +@lisp +(setq slime-lisp-implementations + '((sbcl ("sbcl" "--core" "sbcl.core-for-slime")))) +@end lisp + +For maximum startup speed you can include the Swank server directly in +a core file. The disadvantage of this approach is that the setup is a +bit more involved and that you need to create a new core file when you +want to update @SLIME{} or @acronym{SBCL}. The steps to execute are: + +@example +shell$ sbcl +* (load ".../slime/swank-loader.lisp") +* (save-lisp-and-die "sbcl.core-with-slime") +@end example + +@noindent +Then add this to your @file{.emacs}: + +@lisp +(setq slime-lisp-implementations + '((sbcl ("sbcl" "--core" "sbcl.core-with-slime") + :init (lambda (port-file _) + (format "(swank:start-server %S)\n" port-file))))) +@end lisp + +@noindent +Similar setups should also work for other Lisp implementations. + +@node Loading Contribs +@subsection Loading Contribs +... to be written ... + +@node slime-mode +@chapter Using slime-mode + +@SLIME{}'s commands are provided via @code{slime-mode}, a minor-mode +used in conjunction with Emacs's @code{lisp-mode}. This chapter +describes the @code{slime-mode} and its relatives. + +@menu +* User-interface conventions:: +* Key bindings:: +* Commands:: +* Semantic indentation:: +* Reader conditionals:: +@end menu + +@c ----------------------- +@node User-interface conventions +@section User-interface conventions + +To use @SLIME{} comfortably it is important to understand a few +``global'' user-interface characteristics. The most important +principles are described in this section. + +@menu +* Temporary buffers:: +* Inferior-lisp:: +* Multithreading:: +@end menu + +@c ----------------------- +@node Temporary buffers +@subsection Temporary buffers + +Some @SLIME{} commands create temporary buffers to display their +results. Although these buffers usually have their own special-purpose +major-modes, certain conventions are observed throughout. + +Temporary buffers can be dismissed by pressing @kbd{q}. This kills the +buffer and restores the window configuration as it was before the +buffer was displayed. Temporary buffers can also be killed with the +usual commands like @code{kill-buffer}, in which case the previous +window configuration won't be restored. + +Pressing @kbd{RET} is supposed to ``do the most obvious useful +thing.'' For instance, in an apropos buffer this prints a full +description of the symbol at point, and in an @acronym{XREF} buffer it +displays the source code for the reference at point. This convention +is inherited from Emacs's own buffers for apropos listings, +compilation results, etc. + +Temporary buffers containing Lisp symbols use @code{slime-mode} in +addition to any special mode of their own. This makes the usual +@SLIME{} commands available for describing symbols, looking up +function definitions, and so on. + +@c ----------------------- +@node Inferior-lisp +@subsection @code{*inferior-lisp*} buffer + +@SLIME{} internally uses the @code{comint} package to start Lisp +processes. This has a few user-visible consequences, some good and +some not-so-terribly. To avoid confusion it is useful to understand +the interactions. + +The buffer @code{*inferior-lisp*} contains the Lisp process's own +top-level. This direct access to Lisp is useful for troubleshooting, +and some degree of @SLIME{} integration is available using the +@code{inferior-slime-mode}. However, in normal use we recommend using +the fully-integrated @SLIME{} @REPL{} and ignoring the +@code{*inferior-lisp*} buffer. + +@c ----------------------- +@node Multithreading +@subsection Multithreading + +If the Lisp system supports multithreading, SLIME spawns a new thread +for each request, e.g., @kbd{C-x C-e} creates a new thread to evaluate +the expression. An exception to this rule are requests from the +@REPL{}: all commands entered in the @REPL{} buffer are evaluated in a +dedicated @REPL{} thread. + +Some complications arise with multithreading and special variables. +Non-global special bindings are thread-local, e.g., changing the value +of a let bound special variable in one thread has no effect on the +binding of the variables with the same name in other threads. This +makes it sometimes difficult to change the printer or reader behaviour +for new threads. The variable +@code{swank:*default-worker-thread-bindings*} was introduced for such +situtuations: instead of modifying the global value of a variable, add a +binding the @code{swank:*default-worker-thread-bindings*}. E.g., with +the following code, new threads will read floating point values as +doubles by default: + +@example +(push '(*read-default-float-format* . double-float) + swank:*default-worker-thread-bindings*). +@end example + +@c ----------------------- +@node Key bindings +@section Key bindings + +@quotation +@i{``Are you deliberately spiting Emacs's brilliant online help facilities? The gods will be angry!''} +@end quotation + +@noindent This is a brilliant piece of advice. The Emacs online help facilities +are your most immediate, up-to-date and complete resource for keybinding +information. They are your friends: + +@table @kbd +@kbdanchorc{C-h k <key>, describe-key, ``What does this key do?''} +Describes current function bound to @kbd{<key>} for focus buffer. + +@kbdanchorc{C-h b, describe-bindings, ``Exactly what bindings are available?''} +Lists the current key-bindings for the focus buffer. + +@kbdanchorc{C-h m, describe-mode, ``Tell me all about this mode''} +Shows all the available major mode keys, then the minor mode keys, for +the modes of the focus buffer. + +@kbdanchorc{C-h l, view-lossage, ``Woah@comma{} what key chord did I just do?''} +Shows you the literal sequence of keys you've pressed in order. + + +@c <key> is breaks links PDF, despite that it's not l it's C-h +@c @kbdanchorc{ <key> l, , ``What starts with?''} +@c Lists all keybindings that begin with @code{<key>} for the focus buffer mode. + + +@end table + +@emph{Note:} In this documentation the designation @kbd{C-h} is a +@dfn{cannonical key} which might actually mean Ctrl-h, or F1, or +whatever you have @code{help-command} bound to in your +@code{.emacs}. Here is a common situation: + +@example +(global-set-key [f1] 'help-command) +(global-set-key "\C-h" 'delete-backward-char) +@end example + +@noindent In this situation everywhere you see @kbd{C-h} in the +documentation you would substitute @kbd{F1}. + +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 +own: when entering a three-key sequence, the final key can be pressed +either with control or unmodified. For example, the +@code{slime-describe-symbol} command is bound to @kbd{C-c C-d d}, but +it also works to type @kbd{C-c C-d C-d}. We're simply binding both key +sequences because some people like to hold control for all three keys +and others don't, and with the two-key prefix we're not afraid of +running out of keys. + +There is one exception to this rule, just to trip you up. We never +bind @kbd{C-h} anywhere in a key sequence, so @kbd{C-c C-d C-h} +doesn't do the same thing as @kbd{C-c C-d h}. This is because Emacs +has a built-in default so that typing a prefix followed by @kbd{C-h} +will display all bindings starting with that prefix, so @kbd{C-c C-d +C-h} will actually list the bindings for all documentation commands. +This feature is just a bit too useful to clobber! + +You can assign or change default key bindings globally using the +@code{global-set-key} function in your @file{~/.emacs} file like this: +@example +(global-set-key "\C-c s" 'slime-selector) +@end example +@noindent +which binds @kbd{C-c s} to the function @code{slime-selector}. + +Alternatively, if you want to assign or change a key binding in just a +particular slime mode, you can use the @code{global-set-key} function +in your @file{~/.emacs} file like this: +@example +(define-key slime-repl-mode-map (kbd "C-c ;") + 'slime-insert-balanced-comments) +@end example +@noindent +which binds @kbd{C-c ;} to the function +@code{slime-insert-balanced-comments} in the REPL buffer. + +@c ----------------------- +@node Commands +@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{Command Index}). + +@menu +* Programming:: +* Compilation:: +* Evaluation:: +* Recovery:: +* Inspector:: +* Profiling:: +* Other:: +@end menu + +@c ----------------------- +@node Programming +@subsection Programming commands + +Programming commands are divided into the following categories: +@strong{Completion, Documentation, Cross-reference, Finding +definitions, Macro-expansion, and Disassembly}, discussed in +separate sections below. + +@menu +* Completion:: +* Closure:: +* Indentation:: +* Documentation:: +* Cross-reference:: +* Finding definitions:: +* Macro-expansion:: +* Disassembly:: +@end menu + +@c ----------------------- +@node Completion +@subsubsection Completion commands + +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. + +@table @kbd +@kbditem{M-TAB,slime-complete-symbol} +@itemx ESC TAB +@itemx C-c C-i +@itemx C-M-i +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}). + +@kbditem{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: + +@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 + +@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}. + +@cmditem{slime-fuzzy-completions-mode} +@cmditem{slime-fuzzy-abort} +@end table + + +@c ----------------------- +@node Closure +@subsubsection Closure commands + +Closure commands are used to fill in missing parenthesis. + +@table @kbd +@kbditem{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{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. + +If @code{REGION} is true, operate on the region. Otherwise operate on +the top-level sexp before point. +@end table + + +@c ----------------------- +@node Indentation +@subsubsection Indentation commands + +@table @kbd +@kbditem{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-q, indent-sexp} +Indents the list immediately following point to match the level at point. + +When given a prefix argument, the text around point will always +be treated as a paragraph. This is useful for filling docstrings." +@end table + + +@c ----------------------- +@node Documentation +@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 (@pxref{Key bindings}.) + +@table @kbd + +@kbditem{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. + +@kbditem{C-c C-d d, slime-describe-symbol} +Describe the symbol at point. + +@kbditem{C-c C-f, slime-describe-function} +Describe the function at point. + +@kbditem{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} +Like @code{slime-apropos} but also includes internal symbols by default. + +@kbditem{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} +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}. + +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}. + +@kbditem{C-c C-d ~, common-lisp-hyperspec-format} +Lookup a @emph{format character} in the @cite{Common Lisp Hyperspec}. +@end table + + +@c ----------------------- +@node Cross-reference +@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 built-in @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{Key bindings}. + +@table @kbd +@kbditem{C-c C-w c, slime-who-calls} +Show function callers. + +@kbditem{C-c C-w w, slime-calls-who} +Show all known callees. + +@kbditem{C-c C-w r, slime-who-references} +Show references to global variable. + +@kbditem{C-c C-w b, slime-who-binds} +Show bindings of a global variable. + +@kbditem{C-c C-w s, slime-who-sets} +Show assignments to a global variable. + +@kbditem{C-c C-w m, slime-who-macroexpands} +Show expansions of a macro. + +@cmditem{slime-who-specializes} +Show all known methods specialized on a class. + +@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 +@kbditem{C-c <, slime-list-callers} +List callers of a function. + +@kbditem{C-c >, slime-list-callees} +List callees of a function. + +@end table + + + +@c ----------------------- +@node Finding definitions +@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 + +@kbditem{M-., slime-edit-definition} +Go to the definition of the symbol at point. + +@item M-, +@itemx M-* +@itemx M-x slime-pop-find-definition-stack +@kindex M-, +@findex 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. + +@kbditem{C-x 4 ., slime-edit-definition-other-window} +Like @code{slime-edit-definition} but switchs to the other window to +edit the definition in. + +@kbditem{C-x 5 ., slime-edit-definition-other-frame} +Like @code{slime-edit-definition} but opens another frame to edit the +definition in. + +@cmditem{slime-edit-definition-with-etags} +Use an ETAGS table to find definition at point. + +@end table + +@c ----------------------- +@node Macro-expansion +@subsubsection Macro-expansion commands + +@table @kbd +@kbditem{C-c C-m, 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} +Fully macroexpand the expression at point. + +@cmditem{slime-compiler-macroexpand-1} +Display the compiler-macro expansion of sexp at point. + +@cmditem{slime-compiler-macroexpand} +Repeatedy expamd compiler macros of sexp at point. + +@end table + +For additional minor-mode commands and discussion, +@pxref{slime-macroexpansion-minor-mode}. + + +@c ----------------------- +@node Disassembly +@subsubsection Disassembly commands + +@table @kbd + +@kbditem{C-c M-d, slime-disassemble-symbol} +Disassemble the function definition of the symbol at point. + +@kbditem{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. + +@cmditem{slime-untrace-all} +Untrace all functions. + +@end table + +@c ----------------------- +@node Compilation +@subsection Compilation 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.) + +@table @kbd +@kbditem{C-c C-c, slime-compile-defun} +Compile the top-level form at point. +@cindex compiling functions + +@kbditem{C-c C-y, slime-call-defun} +Insert a call to the function defined around point into the REPL. + +@kbditem{C-c C-k, slime-compile-and-load-file} +Compile and load the current buffer's source file. + +@kbditem{C-c M-k, slime-compile-file} +Compile (but don't load) the current buffer's source file. + +@kbditem{C-c C-l, slime-load-file} +Load a source file and compile if necessary, without loading into a buffer.. + +@kbditem{C-c C-z, slime-switch-to-output-buffer} +Select the output buffer, preferably in a different window. + +@cmditem{slime-compile-region} +Compile region at point. + +@end table + +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. + +@table @kbd +@kbditem{M-n, slime-next-note} +Move the point to the next compiler note and displays the note. + +@kbditem{M-p, slime-previous-note} +Move the point to the previous compiler note and displays the note. + +@kbditem{C-c M-c, slime-remove-notes} +Remove all annotations from the buffer. +@end table + +@c ----------------------- +@node Evaluation +@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-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-x C-e, slime-eval-last-expression} +Evaluate the expression before point. +@end table + +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. + +@table @kbd +@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-x M-e, slime-eval-last-expression-display-output} +Display output buffer and evaluate the expression preceding point. + +@kbditem{C-c :, slime-interactive-eval} +Evaluate an expression read from the minibuffer. + +@anchor{slime-scratch} +@cmditem{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. + +@kbditem{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}. + +@kbditem{C-c C-u, slime-undefine-function} +Unbind symbol for function at point. +@end table + + +@c ----------------------- +@node Recovery +@subsection Abort/Recovery commands + +@table @kbd +@kbditem{C-c C-b, slime-interrupt} +Interrupt Lisp (send @code{SIGINT}). + +@kbditem{C-c ~, slime-sync-package-and-default-directory} +Synchronize the current package and working directory from Emacs to +Lisp. + +@kbditem{C-c M-p, slime-repl-set-package} +Set the current package of the @acronym{REPL}. + +@end table + +@c ----------------------- +@node Inspector +@subsection Inspector commands + +The @SLIME{} inspector is a very fancy Emacs-based alternative to the +standard @code{INSPECT} function. The inspector presents objects in +Emacs buffers using a combination of plain text, hyperlinks to related +objects, and ``actions'' that can be selected to invoke Lisp code on +the inspected object. For example, to present a generic function the +inspector shows the documentation in plain text and presents each +method with both a hyperlink to inspect the method object and a +``remove method'' action that you can invoke interactively. + +The inspector can easily be specialized for the objects in your own +programs. For details see the the @code{inspect-for-emacs} generic +function in @file{swank-backend.lisp}. + +@table @kbd + +@kbditem{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} +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} +Describe the slot at point. + +@kbditem{l, slime-inspector-pop} +Go back to the previous object (return from @kbd{RET}). + +@kbditem{n, slime-inspector-next} +The inverse of @kbd{l}. Also bound to @kbd{SPC}. + +@kbditem{q, slime-inspector-quit} +Dismiss the inspector buffer. + +@kbditem{M-RET, slime-inspector-copy-down} +Evaluate the value under point via the REPL (to set `*'). + +@end table + +@c ----------------------- +@node Profiling +@subsection Profiling commands + +@table @kbd +@cmditem{slime-toggle-profile-fdefinition} +Toggle profiling of a function. +@cmditem{slime-profile-package} +Profile all functions in a package. +@cmditem{slime-unprofile-all} +Unprofile all functions. +@cmditem{slime-profile-report} +Report profiler data. +@cmditem{slime-profile-reset} +Reset profiler data. +@cmditem{slime-profiled-functions} +Show list of currently profiled functions. +@end table + +@c ----------------------- +@node Other +@subsection Shadowed Commands + +@table @kbd + +@kbditempair{C-c C-a, C-c C-v, slime-nop, slime-nop} +This key-binding is shadowed from inf-lisp. + +@end table + +@c ----------------------- +@node Semantic indentation +@section Semantic indentation + +@SLIME{} automatically discovers how to indent the macros in your Lisp +system. To do this the Lisp side scans all the macros in the system and +reports to Emacs all the ones with @code{&body} arguments. Emacs then +indents these specially, putting the first arguments four spaces in and +the ``body'' arguments just two spaces, as usual. + +This should ``just work.'' If you are a lucky sort of person you needn't +read the rest of this section. + +To simplify the implementation, @SLIME{} doesn't distinguish between +macros with the same symbol-name but different packages. This makes it +fit nicely with Emacs's indentation code. However, if you do have +several macros with the same symbol-name then they will all be indented +the same way, arbitrarily using the style from one of their +arglists. You can find out which symbols are involved in collisions +with: + +@example +(swank:print-indentation-lossage) +@end example + +If a collision causes you irritation, don't have a nervous breakdown, +just override the Elisp symbol's @code{common-lisp-indent-function} +property to your taste. @SLIME{} won't override your custom settings, it +just tries to give you good defaults. + +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.} + +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 +whose home package matches the one used by the Emacs buffer where the +request comes from. That is sufficient to pick up the indentation of +most interactively-defined macros. To catch the rest we make a full scan +of every symbol each time a new Lisp package is created between commands +-- that takes care of things like new systems being loaded. + +You can use @kbd{M-x slime-update-indentation} to force all symbols to +be scanned for indentation information. + +@c ----------------------- +@node Reader conditionals +@section Reader conditional fontification + +@SLIME{} automatically evaluates reader-conditional expressions in +source buffers and ``grays out'' code that will be skipped for the +current Lisp connection. + + +@c ----------------------- +@node REPL +@chapter REPL: the ``top level'' + +@SLIME{} uses a custom Read-Eval-Print Loop (@REPL{}, also known as a +``top level''). The @REPL{} user-interface is written in Emacs Lisp, +which gives more Emacs-integration than the traditional +@code{comint}-based Lisp interaction: + +@itemize @bullet +@item +Conditions signalled in @REPL{} expressions are debugged with @SLDB{}. +@item +Return values are distinguished from printed output by separate Emacs +faces (colours). +@item +Emacs manages the @REPL{} prompt with markers. This ensures that Lisp +output is inserted in the right place, and doesn't get mixed up with +user input. +@end itemize + +@menu +* REPL commands:: +* Input Navigation:: +* Shortcuts:: +@end menu + +@c ----------------------- +@node REPL commands +@section REPL commands + +@table @kbd + +@kbditem{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} +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} +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{C-c M-g, slime-quit} +Quit slime. + +@kbditem{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} +Clear the entire buffer, leaving only a prompt. + +@end table + +@c ----------------------- +@node Input Navigation +@section Input navigation + +@table @kbd + +@kbditem{C-a, slime-repl-bol} +Go to the beginning of the line, but stop at the @REPL{} prompt. + +@kbditempair{M-n, M-p, slime-repl-next-input, slime-repl-previous-input} +Go to next/previous in command history. + +@kbditempair{M-s, M-r, +slime-repl-next-matching-input, slime-repl-previous-matching-input} +Search forward/reverse through command history with regex + +@c @code{slime-repl-@{next,previous@}-input}@* +@c @code{slime-repl-@{next,previous@}-matching-input}@* +@c @code{comint}-style input history commands. + +@kbditempair{C-c C-n, C-c C-p, +slime-repl-next-prompt, slime-repl-previous-prompt} +Move between the current and previous prompts in the @REPL{} buffer. + +@kbditempair{C-M-a, C-M-e, +slime-repl-beginning-of-defun, slime-repl-end-of-defun} +These commands are like @code{beginning-of-defun} and +@code{end-of-defun}, but when used inside the @REPL{} input area they +instead go directly to the beginning or the end, respectively. + +@end table + +@c ----------------------- +@comment node-name, next, previous, up +@node Shortcuts +@section Shortcuts + +``Shortcuts'' are a special set of @REPL{} commands that are invoked +by name. To invoke a shortcut you first press @kbd{,} (comma) at the +@REPL{} prompt and then enter the shortcut's name when prompted. + +Shortcuts deal with things like switching between directories and +compiling and loading Lisp systems. The set of shortcuts is listed +below, and you can also use the @code{help} +shortcut to list them interactively. + +@table @kbd +@item change-directory (aka !d, cd) +Change the current directory. + +@item change-package (aka !p) +Change the current package. + +@item compile-and-load (aka cl) +Compile (if neccessary) and load a lisp file. + +@item compile-system +Compile (but not load) an ASDF system. + +@item defparameter (aka !) +Define a new global, special, variable. + +@item force-compile-system +Recompile (but not load) an ASDF system. + +@item force-load-system +Recompile and load an ASDF system. + +@item help (aka ?) +Display the help. + +@item load-system +Compile (as needed) and load an ASDF system. + +@item pop-directory (aka -d) +Pop the current directory. + +@item pop-package (aka -p) +Pop the top of the package stack. + +@item push-directory (aka +d, pushd) +Push a new directory onto the directory stack. + +@item push-package (aka +p) +Push a package onto the package stack. + +@item pwd +Show the current directory. + +@item quit +Quit the current Lisp. + +@item resend-form +Resend the last form. + +@item restart-inferior-lisp +Restart *inferior-lisp* and reconnect SLIME. + +@item sayoonara +Quit all Lisps and close all SLIME buffers. + +@end table + +@c ----------------------- +@node Debugger +@chapter SLDB: the SLIME debugger + +@SLIME{} has a custom Emacs-based debugger called @SLDB{}. Conditions +signalled in the Lisp system invoke @SLDB{} in Emacs by way of the +Lisp @code{*DEBUGGER-HOOK*}. + +@SLDB{} pops up a buffer when a condition is signalled. The buffer +displays a description of the condition, a list of restarts, and a +backtrace. Commands are offered for invoking restarts, examining the +backtrace, and poking around in stack frames. + +@menu +* Examining frames:: +* Restarts:: +* Frame Navigation:: +* Miscellaneous:: +@end menu + +@c ----------------------- +@node Examining frames +@section Examining frames + +Commands for examining the stack frame at point. + +@table @kbd +@kbditem{t, sldb-toggle-details} +Toggle display of local variables and @code{CATCH} tags. + +@kbditem{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} +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} +Evaluate an expression in the frame and pretty-print the result in a +temporary buffer. + +@kbditem{D, sldb-disassemble} +Disassemble the frame's function. Includes information such as the +instruction pointer within the frame. + +@kbditem{i, sldb-inspect-in-frame} +Inspect the result of evaluating an expression in the frame. +@end table + +@c ----------------------- +@node Restarts +@section Invoking restarts + +@table @kbd +@kbditem{a, sldb-abort} +Invoke the @code{ABORT} restart. + +@kbditem{q, sldb-quit} +``Quit'' -- @code{THROW} to a tag that the top-level @SLIME{} +request-loop catches. + +@kbditem{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 +@section Navigating between frames + +@table @kbd +@kbditempair{n,p,sldb-down,sldb-up} +Move between frames. + +@kbditempair{M-n, M-p, sldb-details-down, sldb-details-up} +Move between frames ``with sugar'': hide the details of the original +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 +@section Miscellaneous Commands + +@table @kbd +@kbditem{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} +Return from the frame with a value entered in the minibuffer. (This +command is not available in all implementations.) + +@kbditem{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} +Exit @SLDB{} and debug the condition using the Lisp system's default +debugger. + +@kbditem{C-c :, slime-interactive-eval} +Evaluate an expression entered in the minibuffer. +@end table + + +@c ----------------------- +@node Extras +@chapter Extras + +@menu +* slime-selector:: +* slime-autodoc-mode:: +* slime-macroexpansion-minor-mode:: +* Multiple connections:: +* Typeout frames:: +@end menu + +@c ----------------------- +@node slime-selector +@section @code{slime-selector} + +The @code{slime-selector} command is for quickly switching to +important buffers: the @REPL{}, @SLDB{}, the Lisp source you were just +hacking, etc. Once invoked the command prompts for a single letter to +specify which buffer it should display. Here are some of the options: + +@table @kbd +@item ? +A help buffer listing all @code{slime-selectors}'s available buffers. +@item r +The @REPL{} buffer for the current @SLIME{} connection. +@item d +The most recently activated @SLDB{} buffer for the current connection. +@item l +The most recently visited @code{lisp-mode} source buffer. +@item s +The @code{*slime-scratch*} buffer (@pxref{slime-scratch}). +@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 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. + +@c ----------------------- +@node slime-autodoc-mode +@section @code{slime-autodoc-mode} + +@table @kbd +@cmditem{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 by default in the @code{slime-setup} call of your +@code{~/.emacs}: +@example +(slime-setup '(slime-autodoc)) +@end example + +@c ----------------------- +@node slime-macroexpansion-minor-mode +@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 +@kbditem{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. + +@kbditem{q, slime-temp-buffer-quit} +Close the expansion buffer. + +@end table + +@c ----------------------- +@node Multiple connections +@section Multiple connections + +@SLIME{} is able to connect to multiple Lisp processes at the same +time. The @kbd{M-x slime} command, when invoked with a prefix +argument, will offer to create an additional Lisp process if one is +already running. This is often convenient, but it requires some +understanding to make sure that your @SLIME{} commands execute in the +Lisp that you expect them to. + +Some buffers are tied to specific Lisp processes. Each Lisp connection +has its own @acronym{REPL} buffer, and all expressions entered or +@SLIME{} commands invoked in that buffer are sent to the associated +connection. Other buffers created by @SLIME{} are similarly tied to +the connections they originate from, including @SLDB{} buffers, +apropos result listings, and so on. These buffers are the result of +some interaction with a Lisp process, so commands in them always go +back to that same process. + +Commands executed in other places, such as @code{slime-mode} source +buffers, always use the ``default'' connection. Usually this is the +most recently established connection, but this can be reassigned via +the ``connection list'' buffer: + +@table @kbd +@kbditem{C-c C-x c, slime-list-connections} +Pop up a buffer listing the established connections. + +@kbditem{C-c C-x t, slime-list-threads} +Pop up a buffer listing the current threads. + +@end table + +The buffer displayed by @code{slime-list-connections} gives a one-line +summary of each connection. The summary shows the connection's serial +number, the name of the Lisp implementation, and other details of the +Lisp process. The current ``default'' connection is indicated with an +asterisk. + +The commands available in the connection-list buffer are: + +@table @kbd +@kbditem{RET, slime-goto-connection} +Pop to the @acronym{REPL} buffer of the connection at point. + +@kbditem{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} +Update the connection list in the buffer. + +@kbditem{q, slime-temp-buffer-quit} +Quit the connection list (kill buffer, restore window configuration). + +@kbditem{R, slime-restart-connection-at-point} +Restart the Lisp process for the connection at point. + +@cmditem{slime-connect} +Connect to a running Swank server. + +@cmditem{slime-disconnect} +Disconnect all connections. + +@cmditem{slime-abort-connection} +Abort the current attempt to connect. + +@end table + +@c ----------------------- +@node Typeout frames +@section Typeout frames + +A ``typeout frame'' is a special Emacs frame which is used instead of +the echo area (minibuffer) to display messages from @SLIME{} commands. +This is an optional feature. The advantage of a typeout frame over the +echo area is that it can hold more text, it can be scrolled, and its +contents don't disappear when you press a key. All potentially long +messages are sent to the typeout frame, such as argument lists, macro +expansions, and so on. + +@table @kbd +@cmditem{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 add +the @code{slime-connected-hook} to your @file{~/.emacs} file: + +@example +(add-hook 'slime-connected-hook 'slime-ensure-typeout-frame) +@end example + +@c ----------------------- +@node Customization +@chapter Customization + +@menu +* Emacs-side customization:: +* Lisp-side:: +@end menu + +@c ----------------------- +@node Emacs-side customization +@section Emacs-side + +The Emacs part of @SLIME{} can be configured with the Emacs +@code{customize} system, just use @kbd{M-x customize-group slime +RET}. Because the customize system is self-describing, we only cover a +few important or obscure configuration options here in the manual. + +@table @code + +@item slime-truncate-lines +The value to use for @code{truncate-lines} in line-by-line summary +buffers popped up by @SLIME{}. This is @code{t} by default, which +ensures that lines do not wrap in backtraces, apropos listings, and so +on. It can however cause information to spill off the screen. + +@anchor{slime-complete-symbol-function} +@vindex 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*} +performs completion ``in parallel'' over the hyphen-delimited +sub-words of a symbol name. +@footnote{This style of completion is modelled on @file{completer.el} +by Chris McConnell. That package is bundled with @acronym{ILISP}.} +Formally this means that ``@code{a-b-c}'' can complete to any symbol +matching the regular expression ``@code{^a.*-b.*-c.*}'' (where ``dot'' +matches anything but a hyphen). Examples give a more intuitive +feeling: +@itemize @bullet +@item +@code{m-v-b} completes to @code{multiple-value-bind}. +@item +@code{w-open} is ambiguous: it completes to either +@code{with-open-file} or @code{with-open-stream}. The symbol is +expanded to the longest common completion (@code{with-open-}) and the +point is placed at the first point of ambiguity, which in this case is +the end. +@item +@code{w--stream} completes to @code{with-open-stream}. +@end itemize +An alternative is @code{slime-simple-complete-symbol}, which +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 key binding, defaulting to @kbd{C-c M-i}. +@xref{slime-fuzzy-complete-symbol}, for more information. + +@vindex slime-filename-translations +@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. + +@vindex slime-net-coding-system +@item slime-net-coding-system +If you want to transmit Unicode characters between Emacs and the Lisp +system, you should customize this variable. E.g., if you use SBCL, you +can set: +@example +(setq slime-net-coding-system 'utf-8-unix) +@end example +To actually display Unicode characters you also need appropriate fonts, +otherwise the characters will be rendered as hollow boxes. If you are +using Allegro CL and GNU Emacs, you can also use @code{emacs-mule-unix} +as coding system. GNU Emacs has often nicer fonts for the latter +encoding. + +@end table + +@menu +* Hooks:: +@end menu + +@c ----------------------- +@node Hooks +@subsection Hooks + +@table @code + +@vindex slime-mode-hook +@item slime-mode-hook +This hook is run each time a buffer enters @code{slime-mode}. It is +most useful for setting buffer-local configuration in your Lisp source +buffers. An example use is to enable @code{slime-autodoc-mode} +(@pxref{slime-autodoc-mode}). + +@vindex slime-connected-hook +@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}.) + +@vindex sldb-hook +@item sldb-hook +This hook is run after @SLDB{} is invoked. The hook functions are +called from the @SLDB{} buffer after it is initialized. An example use +is to add @code{sldb-print-condition} to this hook, which makes all +conditions debugged with @SLDB{} be recorded in the @REPL{} buffer. + +@end table + +@c ----------------------- +@node Lisp-side +@section Lisp-side (Swank) + +The Lisp server side of @SLIME{} (known as ``Swank'') offers several +variables to configure. The initialization file @file{~/.swank.lisp} +is automatically evaluated at startup and can be used to set these +variables. + +@menu +* Communication style:: +* Other configurables:: +@end menu + +@c ----------------------- +@node Communication style +@subsection Communication style +@vindex SWANK:*COMMUNICATION-STYLE* + +The most important configurable is @code{SWANK:*COMMUNICATION-STYLE*}, +which specifies the mechanism by which Lisp reads and processes +protocol messages from Emacs. The choice of communication style has a +global influence on @SLIME{}'s operation. + +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 +framework (such as @code{SERVE-EVENT} in @acronym{CMUCL} and +@acronym{SBCL}) and receives a callback when data is available. In +this style requests from Emacs are only detected and processed when +Lisp enters the event-loop. This style is simple and predictable. + +@item :SIGIO +This style uses @dfn{signal-driven I/O} with a @code{SIGIO} signal +handler. Lisp receives requests from Emacs along with a signal, +causing it to interrupt whatever it is doing to serve the +request. This style has the advantage of responsiveness, since Emacs +can perform operations in Lisp even while it is busy doing other +things. It also allows Emacs to issue requests concurrently, e.g. to +send one long-running request (like compilation) and then interrupt +that with several short requests before it completes. The +disadvantages are that it may conflict with other uses of @code{SIGIO} +by Lisp code, and it may cause untold havoc by interrupting Lisp at an +awkward moment. + +@item :SPAWN +This style uses multiprocessing support in the Lisp system to execute +each request in a separate thread. This style has similar properties +to @code{:SIGIO}, but it does not use signals and all requests issued +by Emacs can be executed in parallel. + +@end table + +The default request handling style is chosen according to the +capabilities of your Lisp system. The general order of preference is +@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 +@subsection Other configurables + +These Lisp variables can be configured via your @file{~/.swank.lisp} +file: + +@table @code + +@vindex SWANK:*CONFIGURE-EMACS-INDENTATION* +@item SWANK:*CONFIGURE-EMACS-INDENTATION* +This variable controls whether indentation styles for +@code{&body}-arguments in macros are discovered and sent to Emacs. It +is enabled by default. + +@vindex SWANK:*GLOBALLY-REDIRECT-IO* +@item SWANK:*GLOBALLY-REDIRECT-IO* +When true this causes the standard streams (@code{*standard-output*}, +etc) to be globally redirected to the @REPL{} in Emacs. When +@code{NIL} (the default) these streams are only temporarily redirected +to Emacs using dynamic bindings while handling requests. Note that +@code{*standard-input*} is currently never globally redirected into +Emacs, because it can interact badly with the Lisp's native @REPL{} by +having it try to read from the Emacs one. + +@vindex SWANK:*GLOBAL-DEBUGGER* +@item SWANK:*GLOBAL-DEBUGGER* +When true (the default) this causes @code{*DEBUGGER-HOOK*} to be +globally set to @code{SWANK:SWANK-DEBUGGER-HOOK} and thus for @SLIME{} +to handle all debugging in the Lisp image. This is for debugging +multithreaded and callback-driven applications. + +@vindex SWANK:*SLDB-PRINTER-BINDINGS* +@vindex SWANK:*MACROEXPAND-PRINTER-BINDINGS* +@vindex SWANK:*SWANK-PPRINT-BINDINGS* +@item SWANK:*SLDB-PRINTER-BINDINGS* +@itemx SWANK:*MACROEXPAND-PRINTER-BINDINGS* +@itemx SWANK:*SWANK-PPRINT-BINDINGS* +These variables can be used to customize the printer in various +situations. The values of the variables are association lists of +printer variable names with the corresponding value. E.g., to enable +the pretty printer for formatting backtraces in @SLDB{}, you can use: +@example +(push '(*print-pretty* . t) swank:*sldb-printer-bindings*). +@end example + +@vindex SWANK:*USE-DEDICATED-OUTPUT-STREAM* +@item SWANK:*USE-DEDICATED-OUTPUT-STREAM* +This variable controls whether to use an unsafe efficiency hack for +sending printed output from Lisp to Emacs. The default is @code{nil}, +don't use it, and is strongly recommended to keep. + +When @code{t}, a separate socket is established solely for Lisp to send +printed output to Emacs through, which is faster than sending the output +in protocol-messages to Emacs. However, as nothing can be guaranteed +about the timing between the dedicated output stream and the stream of +protocol messages, the output of a Lisp command can arrive before or +after the corresponding REPL results. Thus output and REPL results can +end up in the wrong order, or even interleaved, in the REPL buffer. +Using a dedicated output stream also makes it more difficult to +communicate to a Lisp running on a remote host via SSH +(@pxref{Connecting to a remote lisp}). + +@vindex SWANK:*DEDICATED-OUTPUT-STREAM-PORT* +@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. + +@vindex SWANK:*LOG-EVENTS* +@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 +useful for low-level debugging and for observing how @SLIME{} works +``on the wire.'' The output of @code{*TERMINAL-IO*} can be found in +your Lisp system's own listener, usually in the buffer +@code{*inferior-lisp*}. + +@end table + +@c ----------------------- +@node Tips and Tricks +@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, so we're not going to talk about it} and we'll only have one +port open we want to tell swank to not use an extra connection for +output (this is actually the default in current SLIME): + +@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. + + +@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 +@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 +@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 is 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 +@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 +@chapter Credits + +@emph{The soppy ending...} + +@unnumberedsec Hackers of the good hack + +@SLIME{} is an Extension of @acronym{SLIM} by Eric Marsden. At the +time of writing, the authors and code-contributors of @SLIME{} are: + +@include contributors.texi + +... not counting the bundled code from @file{hyperspec.el}, +@cite{CLOCC}, and the @cite{CMU AI Repository}. + +Many people on the @code{slime-devel} mailing list have made non-code +contributions to @SLIME{}. Life is hard though: you gotta send code to +get your name in the manual. @code{:-)} + +@unnumberedsec Thanks! + +We're indebted to the good people of @code{common-lisp.net} for their +hosting and help, and for rescuing us from ``Sourceforge hell.'' + +Implementors of the Lisps that we support have been a great help. We'd +like to thank the @acronym{CMUCL} maintainers for their helpful +answers, Craig Norvell and Kevin Layer at Franz providing Allegro CL +licenses for @SLIME{} development, and Peter Graves for his help to +get @SLIME{} running with @acronym{ABCL}. + +Most of all we're happy to be working with the Lisp implementors +who've joined in the @SLIME{} development: Dan Barlow and Christophe +Rhodes of @acronym{SBCL}, Gary Byers of OpenMCL, and Martin Simmons of +LispWorks. Thanks also to Alain Picard and Memetrics for funding +Martin's initial work on the LispWorks backend! + +@ignore +This index is currently ingored, because texinfo's built-in indexing +produces nicer results. -- Helmut Eller + +@node Index to Functions +@appendix Index to Functions + +These functions are all available (when relevant). To find the +keybinding (if there is one) refer to the function description. + +@c Note to editors: @fcnindex{...} lines commented out below are place holders +@c ---------------- +@c They have yet to be documented +@c Please feel free to add descriptions in the text where appropriate, add the +@c appropriate anchors and uncomment them. +@c +@c [jkc] + +@table @code +@fcnindex{common-lisp-hyperspec-format} +@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-mode-hook} +@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} + + +@c @fcnindex{inferior-slime-closing-return} +@c @fcnindex{inferior-slime-indent-line} +@c @fcnindex{inferior-slime-mode} +@c @fcnindex{inferior-slime-return} +@fcnindex{slime-abort-connection} +@fcnindex{slime-apropos} +@fcnindex{slime-apropos-all} +@fcnindex{slime-apropos-package} +@c @fcnindex{slime-arglist} +@fcnindex{slime-autodoc-mode} +@c @fcnindex{slime-autodoc-start-timer} +@c @fcnindex{slime-background-activities-enabled-p} +@c @fcnindex{slime-background-message} +@c @fcnindex{slime-browse-classes} +@c @fcnindex{slime-browse-xrefs} +@fcnindex{slime-call-defun} +@fcnindex{slime-calls-who} +@c @fcnindex{slime-check-coding-system} +@fcnindex{slime-close-all-sexp} +@fcnindex{slime-close-parens-at-point} +@fcnindex{slime-compile-and-load-file} +@fcnindex{slime-compile-defun} +@fcnindex{slime-compile-file} +@fcnindex{slime-compile-region} +@fcnindex{slime-compiler-macroexpand} +@fcnindex{slime-compiler-macroexpand-1} +@c @fcnindex{slime-compiler-notes-default-action-or-show-details} +@c @fcnindex{slime-compiler-notes-default-action-or-show-details/mouse} +@c @fcnindex{slime-compiler-notes-quit} +@c @fcnindex{slime-compiler-notes-show-details} +@c @fcnindex{slime-complete-form} +@fcnindex{slime-complete-symbol} +@fcnindex{slime-connect} +@fcnindex{slime-connection-list-make-default} +@c @fcnindex{slime-connection-list-mode} +@c @fcnindex{slime-copy-presentation-at-point} +@fcnindex{slime-describe-function} +@fcnindex{slime-describe-symbol} +@fcnindex{slime-disassemble-symbol} +@fcnindex{slime-disconnect} +@c @fcnindex{slime-documentation} +@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-commit} +@c @fcnindex{slime-edit-value-mode} +@fcnindex{slime-ensure-typeout-frame} +@c @fcnindex{slime-eval-buffer} +@fcnindex{slime-eval-defun} +@fcnindex{slime-eval-last-expression} +@fcnindex{slime-eval-last-expression-display-output} +@c @fcnindex{slime-eval-print-last-expression} +@fcnindex{slime-eval-region} +@fcnindex{slime-fuzzy-abort} +@fcnindex{slime-fuzzy-complete-symbol} +@fcnindex{slime-fuzzy-completions-mode} +@c @fcnindex{slime-fuzzy-next} +@c @fcnindex{slime-fuzzy-prev} +@c @fcnindex{slime-fuzzy-select} +@c @fcnindex{slime-fuzzy-select/mouse} +@fcnindex{slime-goto-connection} +@fcnindex{slime-goto-xref} +@c @fcnindex{slime-handle-repl-shortcut} +@c @fcnindex{slime-highlight-notes} +@fcnindex{slime-hyperspec-lookup} +@c @fcnindex{slime-indent-and-complete-symbol} +@c @fcnindex{slime-init-keymaps} +@c @fcnindex{slime-insert-arglist} +@c @fcnindex{slime-insert-balanced-comments} +@fcnindex{slime-inspect} +@fcnindex{slime-inspector-copy-down} +@fcnindex{slime-inspector-describe} +@fcnindex{slime-inspector-next} +@c @fcnindex{slime-inspector-next-inspectable-object} +@fcnindex{slime-inspector-quit} +@c @fcnindex{slime-inspector-reinspect} +@fcnindex{slime-interactive-eval} +@fcnindex{slime-interrupt} +@fcnindex{slime-list-callees} +@fcnindex{slime-list-callers} +@c @fcnindex{slime-list-compiler-notes} +@fcnindex{slime-list-connections} +@c @fcnindex{slime-list-repl-shortcuts} +@fcnindex{slime-list-threads} +@fcnindex{slime-load-file} +@c @fcnindex{slime-load-system} +@fcnindex{slime-macroexpand-1} +@fcnindex{slime-macroexpand-1-inplace} +@fcnindex{slime-macroexpand-all} +@c @fcnindex{slime-make-default-connection} +@c @fcnindex{slime-make-typeout-frame} +@fcnindex{slime-mode} +@c @fcnindex{slime-next-line/not-add-newlines} +@c @fcnindex{slime-next-location} +@fcnindex{slime-next-note} +@fcnindex{slime-nop} +@c @fcnindex{slime-ping} +@fcnindex{slime-pop-find-definition-stack} +@fcnindex{slime-pprint-eval-last-expression} +@c @fcnindex{slime-presentation-menu} +@c @fcnindex{slime-pretty-lambdas} +@fcnindex{slime-previous-note} +@fcnindex{slime-profile-package} +@fcnindex{slime-profile-report} +@fcnindex{slime-profile-reset} +@fcnindex{slime-profiled-functions} +@fcnindex{slime-quit} +@c @fcnindex{slime-quit-connection-at-point} +@c @fcnindex{slime-quit-lisp} +@c @fcnindex{slime-re-evaluate-defvar} +@c @fcnindex{slime-recompile-bytecode} +@c @fcnindex{slime-register-lisp-implementation} +@fcnindex{slime-reindent-defun} +@c @fcnindex{slime-remove-balanced-comments} +@fcnindex{slime-remove-notes} +@c @fcnindex{slime-repl} +@fcnindex{slime-repl-beginning-of-defun} +@fcnindex{slime-repl-bol} +@fcnindex{slime-repl-clear-buffer} +@fcnindex{slime-repl-clear-output} +@fcnindex{slime-repl-closing-return} +@c @fcnindex{slime-repl-compile-and-load} +@c @fcnindex{slime-repl-compile-system} +@c @fcnindex{slime-repl-compile/force-system} +@c @fcnindex{slime-repl-defparameter} +@fcnindex{slime-repl-end-of-defun} +@c @fcnindex{slime-repl-eol} +@c @fcnindex{slime-repl-load-system} +@c @fcnindex{slime-repl-load/force-system} +@c @fcnindex{slime-repl-mode} +@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-pop-directory} +@c @fcnindex{slime-repl-pop-packages} +@fcnindex{slime-repl-previous-input} +@fcnindex{slime-repl-previous-matching-input} +@fcnindex{slime-repl-previous-prompt} +@c @fcnindex{slime-repl-push-directory} +@c @fcnindex{slime-repl-push-package} +@c @fcnindex{slime-repl-read-break} +@c @fcnindex{slime-repl-read-mode} +@fcnindex{slime-repl-return} +@fcnindex{slime-repl-set-package} +@c @fcnindex{slime-repl-shortcut-help} +@c @fcnindex{slime-reset} +@c @fcnindex{slime-restart-connection-at-point} +@c @fcnindex{slime-restart-inferior-lisp} +@c @fcnindex{slime-restart-inferior-lisp-aux} +@fcnindex{slime-scratch} +@c @fcnindex{slime-select-lisp-implementation} +@fcnindex{slime-selector} +@c @fcnindex{slime-send-sigint} +@c @fcnindex{slime-set-default-directory} +@c @fcnindex{slime-set-package} +@c @fcnindex{slime-show-xref} +@fcnindex{slime-space} +@c @fcnindex{slime-start-and-load} +@fcnindex{slime-switch-to-output-buffer} +@fcnindex{slime-sync-package-and-default-directory} +@c @fcnindex{slime-temp-buffer-mode} +@fcnindex{slime-temp-buffer-quit} +@c @fcnindex{slime-thread-attach} +@c @fcnindex{slime-thread-debug} +@c @fcnindex{slime-thread-control-mode} +@c @fcnindex{slime-thread-kill} +@c @fcnindex{slime-thread-quit} +@fcnindex{slime-toggle-profile-fdefinition} +@fcnindex{slime-toggle-trace-fdefinition} +@fcnindex{slime-undefine-function} +@fcnindex{slime-unprofile-all} +@fcnindex{slime-untrace-all} +@fcnindex{slime-update-connection-list} +@c @fcnindex{slime-update-indentation} ??? +@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-xref-mode} +@c @fcnindex{slime-xref-quit} +@end table + +@end ignore + +@node Key Index, Command Index, Credits, top +@unnumbered Key (Character) Index +@printindex ky + +@node Command Index, Variable Index, Key Index, top +@unnumbered Command and Function Index +@printindex fn + +@node Variable Index, , Command Index, top +@unnumbered Variable Index +@printindex vr + +@bye
Added: branches/trunk-reorg/thirdparty/slime/doc/texinfo-tabulate.awk =================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/texinfo-tabulate.awk 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/doc/texinfo-tabulate.awk 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,21 @@ +#!/usr/bin/env awk -f +# +# 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"); + for (i = 0; i < columns; i++) + printf(" %f", 1.0/columns); + print +} + +{ if (NR % columns == 1) printf("\n@item %s", $0); + else printf(" @tab %s", $0); } + +END { printf("\n@end multitable\n"); } +
Added: branches/trunk-reorg/thirdparty/slime/hyperspec.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/hyperspec.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/hyperspec.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,1671 @@ +;;; hyperspec.el --- Browse documentation from the Common Lisp HyperSpec + +;; Copyright 1997 Naggum Software + +;; Author: Erik Naggum erik@naggum.no +;; Keywords: lisp + +;; This file is not part of GNU Emacs, but distributed under the same +;; conditions as GNU Emacs, and is useless without GNU Emacs. + +;; GNU Emacs 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. + +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Kent Pitman and Xanalys Inc. have made the text of American National +;; Standard for Information Technology -- Programming Language -- Common +;; Lisp, ANSI X3.226-1994 available on the WWW, in the form of the Common +;; Lisp HyperSpec. This package makes it convenient to peruse this +;; documentation from within Emacs. + +;;; Code: + +(require 'cl) +(require 'browse-url) ;you need the Emacs 20 version +(require 'thingatpt) + +(defvar common-lisp-hyperspec-root + "http://www.lispworks.com/reference/HyperSpec/" + "The root of the Common Lisp HyperSpec URL. +If you copy the HyperSpec to your local system, set this variable to +something like "file:/usr/local/doc/HyperSpec/".") + +;;; Added variable for CLHS symbol table. See details below. +;;; +;;; 20011201 Edi Weitz + +(defvar common-lisp-hyperspec-symbol-table nil + "The HyperSpec symbol table file. +If you copy the HyperSpec to your local system, set this variable to +the location of the symbol table which is usually "Map_Sym.txt" +or "Symbol-Table.text".") + +(defvar common-lisp-hyperspec-history nil + "History of symbols looked up in the Common Lisp HyperSpec.") + +;;if only we had had packages or hash tables..., but let's fake it. + +(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 +your favorite browser in sequence. The browser should have a "back" +function to view the separate definitions. + +The Common Lisp HyperSpec is the full ANSI Standard Common Lisp, provided +by Kent Pitman and Xanalys Inc. By default, the Xanalys Web site is +visited to retrieve the information. Xanalys Inc. allows you to transfer +the entire Common Lisp HyperSpec to your own site under certain conditions. +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)) + (stripped-symbol + (and symbol-at-point + (substring-no-properties + (downcase + (common-lisp-hyperspec-strip-cl-package + symbol-at-point)))))) + (if (and stripped-symbol + (intern-soft stripped-symbol + common-lisp-hyperspec-symbols)) + stripped-symbol + (completing-read + "Look up symbol in Common Lisp HyperSpec: " + common-lisp-hyperspec-symbols #'boundp + 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 + (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" + symbol-name))))) + +;;; Added the following just to provide a common entry point according +;;; to the various 'hyperspec' implementations. +;;; +;;; 19990820 Marco Antoniotti + +(eval-when (load eval) + (defalias 'hyperspec-lookup 'common-lisp-hyperspec)) + + +;;; Added dynamic lookup of symbol in CLHS symbol table +;;; +;;; 20011202 Edi Weitz + +;;; Replaced symbol table for v 4.0 with the one for v 6.0 +;;; (which is now online at Xanalys' site) +;;; +;;; 20020213 Edi Weitz + +(if common-lisp-hyperspec-symbol-table + (let ((index-buffer (find-file-noselect common-lisp-hyperspec-symbol-table))) + (labels ((get-one-line () + (prog1 + (delete* ?\n (thing-at-point 'line)) + (forward-line)))) + (save-excursion + (set-buffer index-buffer) + (goto-char (point-min)) + (while (< (point) (point-max)) + (let* ((symbol (intern (downcase (get-one-line)) + common-lisp-hyperspec-symbols)) + (relative-url (get-one-line))) + (set symbol (list (subseq relative-url + (1+ (position ?/ relative-url :from-end t)))))))))) + (mapcar (lambda (entry) + (let ((symbol (intern (car entry) common-lisp-hyperspec-symbols))) + (if (boundp symbol) + (push (cadr entry) (symbol-value symbol)) + (set symbol (cdr entry))))) + '(("&allow-other-keys" "03_da.htm") + ("&aux" "03_da.htm") + ("&body" "03_dd.htm") + ("&environment" "03_dd.htm") + ("&key" "03_da.htm") + ("&optional" "03_da.htm") + ("&rest" "03_da.htm") + ("&whole" "03_dd.htm") + ("*" "a_st.htm") + ("**" "v__stst_.htm") + ("***" "v__stst_.htm") + ("*break-on-signals*" "v_break_.htm") + ("*compile-file-pathname*" "v_cmp_fi.htm") + ("*compile-file-truename*" "v_cmp_fi.htm") + ("*compile-print*" "v_cmp_pr.htm") + ("*compile-verbose*" "v_cmp_pr.htm") + ("*debug-io*" "v_debug_.htm") + ("*debugger-hook*" "v_debugg.htm") + ("*default-pathname-defaults*" "v_defaul.htm") + ("*error-output*" "v_debug_.htm") + ("*features*" "v_featur.htm") + ("*gensym-counter*" "v_gensym.htm") + ("*load-pathname*" "v_ld_pns.htm") + ("*load-print*" "v_ld_prs.htm") + ("*load-truename*" "v_ld_pns.htm") + ("*load-verbose*" "v_ld_prs.htm") + ("*macroexpand-hook*" "v_mexp_h.htm") + ("*modules*" "v_module.htm") + ("*package*" "v_pkg.htm") + ("*print-array*" "v_pr_ar.htm") + ("*print-base*" "v_pr_bas.htm") + ("*print-case*" "v_pr_cas.htm") + ("*print-circle*" "v_pr_cir.htm") + ("*print-escape*" "v_pr_esc.htm") + ("*print-gensym*" "v_pr_gen.htm") + ("*print-length*" "v_pr_lev.htm") + ("*print-level*" "v_pr_lev.htm") + ("*print-lines*" "v_pr_lin.htm") + ("*print-miser-width*" "v_pr_mis.htm") + ("*print-pprint-dispatch*" "v_pr_ppr.htm") + ("*print-pretty*" "v_pr_pre.htm") + ("*print-radix*" "v_pr_bas.htm") + ("*print-readably*" "v_pr_rda.htm") + ("*print-right-margin*" "v_pr_rig.htm") + ("*query-io*" "v_debug_.htm") + ("*random-state*" "v_rnd_st.htm") + ("*read-base*" "v_rd_bas.htm") + ("*read-default-float-format*" "v_rd_def.htm") + ("*read-eval*" "v_rd_eva.htm") + ("*read-suppress*" "v_rd_sup.htm") + ("*readtable*" "v_rdtabl.htm") + ("*standard-input*" "v_debug_.htm") + ("*standard-output*" "v_debug_.htm") + ("*terminal-io*" "v_termin.htm") + ("*trace-output*" "v_debug_.htm") + ("+" "a_pl.htm") + ("++" "v_pl_plp.htm") + ("+++" "v_pl_plp.htm") + ("-" "a__.htm") + ("/" "a_sl.htm") + ("//" "v_sl_sls.htm") + ("///" "v_sl_sls.htm") + ("/=" "f_eq_sle.htm") + ("1+" "f_1pl_1_.htm") + ("1-" "f_1pl_1_.htm") + ("<" "f_eq_sle.htm") + ("<=" "f_eq_sle.htm") + ("=" "f_eq_sle.htm") + (">" "f_eq_sle.htm") + (">=" "f_eq_sle.htm") + ("abort" "a_abort.htm") + ("abs" "f_abs.htm") + ("acons" "f_acons.htm") + ("acos" "f_asin_.htm") + ("acosh" "f_sinh_.htm") + ("add-method" "f_add_me.htm") + ("adjoin" "f_adjoin.htm") + ("adjust-array" "f_adjust.htm") + ("adjustable-array-p" "f_adju_1.htm") + ("allocate-instance" "f_alloca.htm") + ("alpha-char-p" "f_alpha_.htm") + ("alphanumericp" "f_alphan.htm") + ("and" "a_and.htm") + ("append" "f_append.htm") + ("apply" "f_apply.htm") + ("apropos" "f_apropo.htm") + ("apropos-list" "f_apropo.htm") + ("aref" "f_aref.htm") + ("arithmetic-error" "e_arithm.htm") + ("arithmetic-error-operands" "f_arithm.htm") + ("arithmetic-error-operation" "f_arithm.htm") + ("array" "t_array.htm") + ("array-dimension" "f_ar_dim.htm") + ("array-dimension-limit" "v_ar_dim.htm") + ("array-dimensions" "f_ar_d_1.htm") + ("array-displacement" "f_ar_dis.htm") + ("array-element-type" "f_ar_ele.htm") + ("array-has-fill-pointer-p" "f_ar_has.htm") + ("array-in-bounds-p" "f_ar_in_.htm") + ("array-rank" "f_ar_ran.htm") + ("array-rank-limit" "v_ar_ran.htm") + ("array-row-major-index" "f_ar_row.htm") + ("array-total-size" "f_ar_tot.htm") + ("array-total-size-limit" "v_ar_tot.htm") + ("arrayp" "f_arrayp.htm") + ("ash" "f_ash.htm") + ("asin" "f_asin_.htm") + ("asinh" "f_sinh_.htm") + ("assert" "m_assert.htm") + ("assoc" "f_assocc.htm") + ("assoc-if" "f_assocc.htm") + ("assoc-if-not" "f_assocc.htm") + ("atan" "f_asin_.htm") + ("atanh" "f_sinh_.htm") + ("atom" "a_atom.htm") + ("base-char" "t_base_c.htm") + ("base-string" "t_base_s.htm") + ("bignum" "t_bignum.htm") + ("bit" "a_bit.htm") + ("bit-and" "f_bt_and.htm") + ("bit-andc1" "f_bt_and.htm") + ("bit-andc2" "f_bt_and.htm") + ("bit-eqv" "f_bt_and.htm") + ("bit-ior" "f_bt_and.htm") + ("bit-nand" "f_bt_and.htm") + ("bit-nor" "f_bt_and.htm") + ("bit-not" "f_bt_and.htm") + ("bit-orc1" "f_bt_and.htm") + ("bit-orc2" "f_bt_and.htm") + ("bit-vector" "t_bt_vec.htm") + ("bit-vector-p" "f_bt_vec.htm") + ("bit-xor" "f_bt_and.htm") + ("block" "s_block.htm") + ("boole" "f_boole.htm") + ("boole-1" "v_b_1_b.htm") + ("boole-2" "v_b_1_b.htm") + ("boole-and" "v_b_1_b.htm") + ("boole-andc1" "v_b_1_b.htm") + ("boole-andc2" "v_b_1_b.htm") + ("boole-c1" "v_b_1_b.htm") + ("boole-c2" "v_b_1_b.htm") + ("boole-clr" "v_b_1_b.htm") + ("boole-eqv" "v_b_1_b.htm") + ("boole-ior" "v_b_1_b.htm") + ("boole-nand" "v_b_1_b.htm") + ("boole-nor" "v_b_1_b.htm") + ("boole-orc1" "v_b_1_b.htm") + ("boole-orc2" "v_b_1_b.htm") + ("boole-set" "v_b_1_b.htm") + ("boole-xor" "v_b_1_b.htm") + ("boolean" "t_ban.htm") + ("both-case-p" "f_upper_.htm") + ("boundp" "f_boundp.htm") + ("break" "f_break.htm") + ("broadcast-stream" "t_broadc.htm") + ("broadcast-stream-streams" "f_broadc.htm") + ("built-in-class" "t_built_.htm") + ("butlast" "f_butlas.htm") + ("byte" "f_by_by.htm") + ("byte-position" "f_by_by.htm") + ("byte-size" "f_by_by.htm") + ("caaaar" "f_car_c.htm") + ("caaadr" "f_car_c.htm") + ("caaar" "f_car_c.htm") + ("caadar" "f_car_c.htm") + ("caaddr" "f_car_c.htm") + ("caadr" "f_car_c.htm") + ("caar" "f_car_c.htm") + ("cadaar" "f_car_c.htm") + ("cadadr" "f_car_c.htm") + ("cadar" "f_car_c.htm") + ("caddar" "f_car_c.htm") + ("cadddr" "f_car_c.htm") + ("caddr" "f_car_c.htm") + ("cadr" "f_car_c.htm") + ("call-arguments-limit" "v_call_a.htm") + ("call-method" "m_call_m.htm") + ("call-next-method" "f_call_n.htm") + ("car" "f_car_c.htm") + ("case" "m_case_.htm") + ("catch" "s_catch.htm") + ("ccase" "m_case_.htm") + ("cdaaar" "f_car_c.htm") + ("cdaadr" "f_car_c.htm") + ("cdaar" "f_car_c.htm") + ("cdadar" "f_car_c.htm") + ("cdaddr" "f_car_c.htm") + ("cdadr" "f_car_c.htm") + ("cdar" "f_car_c.htm") + ("cddaar" "f_car_c.htm") + ("cddadr" "f_car_c.htm") + ("cddar" "f_car_c.htm") + ("cdddar" "f_car_c.htm") + ("cddddr" "f_car_c.htm") + ("cdddr" "f_car_c.htm") + ("cddr" "f_car_c.htm") + ("cdr" "f_car_c.htm") + ("ceiling" "f_floorc.htm") + ("cell-error" "e_cell_e.htm") + ("cell-error-name" "f_cell_e.htm") + ("cerror" "f_cerror.htm") + ("change-class" "f_chg_cl.htm") + ("char" "f_char_.htm") + ("char-code" "f_char_c.htm") + ("char-code-limit" "v_char_c.htm") + ("char-downcase" "f_char_u.htm") + ("char-equal" "f_chareq.htm") + ("char-greaterp" "f_chareq.htm") + ("char-int" "f_char_i.htm") + ("char-lessp" "f_chareq.htm") + ("char-name" "f_char_n.htm") + ("char-not-equal" "f_chareq.htm") + ("char-not-greaterp" "f_chareq.htm") + ("char-not-lessp" "f_chareq.htm") + ("char-upcase" "f_char_u.htm") + ("char/=" "f_chareq.htm") + ("char<" "f_chareq.htm") + ("char<=" "f_chareq.htm") + ("char=" "f_chareq.htm") + ("char>" "f_chareq.htm") + ("char>=" "f_chareq.htm") + ("character" "a_ch.htm") + ("characterp" "f_chp.htm") + ("check-type" "m_check_.htm") + ("cis" "f_cis.htm") + ("class" "t_class.htm") + ("class-name" "f_class_.htm") + ("class-of" "f_clas_1.htm") + ("clear-input" "f_clear_.htm") + ("clear-output" "f_finish.htm") + ("close" "f_close.htm") + ("clrhash" "f_clrhas.htm") + ("code-char" "f_code_c.htm") + ("coerce" "f_coerce.htm") + ("compilation-speed" "d_optimi.htm") + ("compile" "f_cmp.htm") + ("compile-file" "f_cmp_fi.htm") + ("compile-file-pathname" "f_cmp__1.htm") + ("compiled-function" "t_cmpd_f.htm") + ("compiled-function-p" "f_cmpd_f.htm") + ("compiler-macro" "f_docume.htm") + ("compiler-macro-function" "f_cmp_ma.htm") + ("complement" "f_comple.htm") + ("complex" "a_comple.htm") + ("complexp" "f_comp_3.htm") + ("compute-applicable-methods" "f_comput.htm") + ("compute-restarts" "f_comp_1.htm") + ("concatenate" "f_concat.htm") + ("concatenated-stream" "t_concat.htm") + ("concatenated-stream-streams" "f_conc_1.htm") + ("cond" "m_cond.htm") + ("condition" "e_cnd.htm") + ("conjugate" "f_conjug.htm") + ("cons" "a_cons.htm") + ("consp" "f_consp.htm") + ("constantly" "f_cons_1.htm") + ("constantp" "f_consta.htm") + ("continue" "a_contin.htm") + ("control-error" "e_contro.htm") + ("copy-alist" "f_cp_ali.htm") + ("copy-list" "f_cp_lis.htm") + ("copy-pprint-dispatch" "f_cp_ppr.htm") + ("copy-readtable" "f_cp_rdt.htm") + ("copy-seq" "f_cp_seq.htm") + ("copy-structure" "f_cp_stu.htm") + ("copy-symbol" "f_cp_sym.htm") + ("copy-tree" "f_cp_tre.htm") + ("cos" "f_sin_c.htm") + ("cosh" "f_sinh_.htm") + ("count" "f_countc.htm") + ("count-if" "f_countc.htm") + ("count-if-not" "f_countc.htm") + ("ctypecase" "m_tpcase.htm") + ("debug" "d_optimi.htm") + ("decf" "m_incf_.htm") + ("declaim" "m_declai.htm") + ("declaration" "d_declar.htm") + ("declare" "s_declar.htm") + ("decode-float" "f_dec_fl.htm") + ("decode-universal-time" "f_dec_un.htm") + ("defclass" "m_defcla.htm") + ("defconstant" "m_defcon.htm") + ("defgeneric" "m_defgen.htm") + ("define-compiler-macro" "m_define.htm") + ("define-condition" "m_defi_5.htm") + ("define-method-combination" "m_defi_4.htm") + ("define-modify-macro" "m_defi_2.htm") + ("define-setf-expander" "m_defi_3.htm") + ("define-symbol-macro" "m_defi_1.htm") + ("defmacro" "m_defmac.htm") + ("defmethod" "m_defmet.htm") + ("defpackage" "m_defpkg.htm") + ("defparameter" "m_defpar.htm") + ("defsetf" "m_defset.htm") + ("defstruct" "m_defstr.htm") + ("deftype" "m_deftp.htm") + ("defun" "m_defun.htm") + ("defvar" "m_defpar.htm") + ("delete" "f_rm_rm.htm") + ("delete-duplicates" "f_rm_dup.htm") + ("delete-file" "f_del_fi.htm") + ("delete-if" "f_rm_rm.htm") + ("delete-if-not" "f_rm_rm.htm") + ("delete-package" "f_del_pk.htm") + ("denominator" "f_numera.htm") + ("deposit-field" "f_deposi.htm") + ("describe" "f_descri.htm") + ("describe-object" "f_desc_1.htm") + ("destructuring-bind" "m_destru.htm") + ("digit-char" "f_digit_.htm") + ("digit-char-p" "f_digi_1.htm") + ("directory" "f_dir.htm") + ("directory-namestring" "f_namest.htm") + ("disassemble" "f_disass.htm") + ("division-by-zero" "e_divisi.htm") + ("do" "m_do_do.htm") + ("do*" "m_do_do.htm") + ("do-all-symbols" "m_do_sym.htm") + ("do-external-symbols" "m_do_sym.htm") + ("do-symbols" "m_do_sym.htm") + ("documentation" "f_docume.htm") + ("dolist" "m_dolist.htm") + ("dotimes" "m_dotime.htm") + ("double-float" "t_short_.htm") + ("double-float-epsilon" "v_short_.htm") + ("double-float-negative-epsilon" "v_short_.htm") + ("dpb" "f_dpb.htm") + ("dribble" "f_dribbl.htm") + ("dynamic-extent" "d_dynami.htm") + ("ecase" "m_case_.htm") + ("echo-stream" "t_echo_s.htm") + ("echo-stream-input-stream" "f_echo_s.htm") + ("echo-stream-output-stream" "f_echo_s.htm") + ("ed" "f_ed.htm") + ("eighth" "f_firstc.htm") + ("elt" "f_elt.htm") + ("encode-universal-time" "f_encode.htm") + ("end-of-file" "e_end_of.htm") + ("endp" "f_endp.htm") + ("enough-namestring" "f_namest.htm") + ("ensure-directories-exist" "f_ensu_1.htm") + ("ensure-generic-function" "f_ensure.htm") + ("eq" "f_eq.htm") + ("eql" "a_eql.htm") + ("equal" "f_equal.htm") + ("equalp" "f_equalp.htm") + ("error" "a_error.htm") + ("etypecase" "m_tpcase.htm") + ("eval" "f_eval.htm") + ("eval-when" "s_eval_w.htm") + ("evenp" "f_evenpc.htm") + ("every" "f_everyc.htm") + ("exp" "f_exp_e.htm") + ("export" "f_export.htm") + ("expt" "f_exp_e.htm") + ("extended-char" "t_extend.htm") + ("fboundp" "f_fbound.htm") + ("fceiling" "f_floorc.htm") + ("fdefinition" "f_fdefin.htm") + ("ffloor" "f_floorc.htm") + ("fifth" "f_firstc.htm") + ("file-author" "f_file_a.htm") + ("file-error" "e_file_e.htm") + ("file-error-pathname" "f_file_e.htm") + ("file-length" "f_file_l.htm") + ("file-namestring" "f_namest.htm") + ("file-position" "f_file_p.htm") + ("file-stream" "t_file_s.htm") + ("file-string-length" "f_file_s.htm") + ("file-write-date" "f_file_w.htm") + ("fill" "f_fill.htm") + ("fill-pointer" "f_fill_p.htm") + ("find" "f_find_.htm") + ("find-all-symbols" "f_find_a.htm") + ("find-class" "f_find_c.htm") + ("find-if" "f_find_.htm") + ("find-if-not" "f_find_.htm") + ("find-method" "f_find_m.htm") + ("find-package" "f_find_p.htm") + ("find-restart" "f_find_r.htm") + ("find-symbol" "f_find_s.htm") + ("finish-output" "f_finish.htm") + ("first" "f_firstc.htm") + ("fixnum" "t_fixnum.htm") + ("flet" "s_flet_.htm") + ("float" "a_float.htm") + ("float-digits" "f_dec_fl.htm") + ("float-precision" "f_dec_fl.htm") + ("float-radix" "f_dec_fl.htm") + ("float-sign" "f_dec_fl.htm") + ("floating-point-inexact" "e_floa_1.htm") + ("floating-point-invalid-operation" "e_floati.htm") + ("floating-point-overflow" "e_floa_2.htm") + ("floating-point-underflow" "e_floa_3.htm") + ("floatp" "f_floatp.htm") + ("floor" "f_floorc.htm") + ("fmakunbound" "f_fmakun.htm") + ("force-output" "f_finish.htm") + ("format" "f_format.htm") + ("formatter" "m_format.htm") + ("fourth" "f_firstc.htm") + ("fresh-line" "f_terpri.htm") + ("fround" "f_floorc.htm") + ("ftruncate" "f_floorc.htm") + ("ftype" "d_ftype.htm") + ("funcall" "f_funcal.htm") + ("function" "a_fn.htm") + ("function-keywords" "f_fn_kwd.htm") + ("function-lambda-expression" "f_fn_lam.htm") + ("functionp" "f_fnp.htm") + ("gcd" "f_gcd.htm") + ("generic-function" "t_generi.htm") + ("gensym" "f_gensym.htm") + ("gentemp" "f_gentem.htm") + ("get" "f_get.htm") + ("get-decoded-time" "f_get_un.htm") + ("get-dispatch-macro-character" "f_set__1.htm") + ("get-internal-real-time" "f_get_in.htm") + ("get-internal-run-time" "f_get__1.htm") + ("get-macro-character" "f_set_ma.htm") + ("get-output-stream-string" "f_get_ou.htm") + ("get-properties" "f_get_pr.htm") + ("get-setf-expansion" "f_get_se.htm") + ("get-universal-time" "f_get_un.htm") + ("getf" "f_getf.htm") + ("gethash" "f_gethas.htm") + ("go" "s_go.htm") + ("graphic-char-p" "f_graphi.htm") + ("handler-bind" "m_handle.htm") + ("handler-case" "m_hand_1.htm") + ("hash-table" "t_hash_t.htm") + ("hash-table-count" "f_hash_1.htm") + ("hash-table-p" "f_hash_t.htm") + ("hash-table-rehash-size" "f_hash_2.htm") + ("hash-table-rehash-threshold" "f_hash_3.htm") + ("hash-table-size" "f_hash_4.htm") + ("hash-table-test" "f_hash_5.htm") + ("host-namestring" "f_namest.htm") + ("identity" "f_identi.htm") + ("if" "s_if.htm") + ("ignorable" "d_ignore.htm") + ("ignore" "d_ignore.htm") + ("ignore-errors" "m_ignore.htm") + ("imagpart" "f_realpa.htm") + ("import" "f_import.htm") + ("in-package" "m_in_pkg.htm") + ("incf" "m_incf_.htm") + ("initialize-instance" "f_init_i.htm") + ("inline" "d_inline.htm") + ("input-stream-p" "f_in_stm.htm") + ("inspect" "f_inspec.htm") + ("integer" "t_intege.htm") + ("integer-decode-float" "f_dec_fl.htm") + ("integer-length" "f_intege.htm") + ("integerp" "f_inte_1.htm") + ("interactive-stream-p" "f_intera.htm") + ("intern" "f_intern.htm") + ("internal-time-units-per-second" "v_intern.htm") + ("intersection" "f_isec_.htm") + ("invalid-method-error" "f_invali.htm") + ("invoke-debugger" "f_invoke.htm") + ("invoke-restart" "f_invo_1.htm") + ("invoke-restart-interactively" "f_invo_2.htm") + ("isqrt" "f_sqrt_.htm") + ("keyword" "t_kwd.htm") + ("keywordp" "f_kwdp.htm") + ("labels" "s_flet_.htm") + ("lambda" "a_lambda.htm") + ("lambda-list-keywords" "v_lambda.htm") + ("lambda-parameters-limit" "v_lamb_1.htm") + ("last" "f_last.htm") + ("lcm" "f_lcm.htm") + ("ldb" "f_ldb.htm") + ("ldb-test" "f_ldb_te.htm") + ("ldiff" "f_ldiffc.htm") + ("least-negative-double-float" "v_most_1.htm") + ("least-negative-long-float" "v_most_1.htm") + ("least-negative-normalized-double-float" "v_most_1.htm") + ("least-negative-normalized-long-float" "v_most_1.htm") + ("least-negative-normalized-short-float" "v_most_1.htm") + ("least-negative-normalized-single-float" "v_most_1.htm") + ("least-negative-short-float" "v_most_1.htm") + ("least-negative-single-float" "v_most_1.htm") + ("least-positive-double-float" "v_most_1.htm") + ("least-positive-long-float" "v_most_1.htm") + ("least-positive-normalized-double-float" "v_most_1.htm") + ("least-positive-normalized-long-float" "v_most_1.htm") + ("least-positive-normalized-short-float" "v_most_1.htm") + ("least-positive-normalized-single-float" "v_most_1.htm") + ("least-positive-short-float" "v_most_1.htm") + ("least-positive-single-float" "v_most_1.htm") + ("length" "f_length.htm") + ("let" "s_let_l.htm") + ("let*" "s_let_l.htm") + ("lisp-implementation-type" "f_lisp_i.htm") + ("lisp-implementation-version" "f_lisp_i.htm") + ("list" "a_list.htm") + ("list*" "f_list_.htm") + ("list-all-packages" "f_list_a.htm") + ("list-length" "f_list_l.htm") + ("listen" "f_listen.htm") + ("listp" "f_listp.htm") + ("load" "f_load.htm") + ("load-logical-pathname-translations" "f_ld_log.htm") + ("load-time-value" "s_ld_tim.htm") + ("locally" "s_locall.htm") + ("log" "f_log.htm") + ("logand" "f_logand.htm") + ("logandc1" "f_logand.htm") + ("logandc2" "f_logand.htm") + ("logbitp" "f_logbtp.htm") + ("logcount" "f_logcou.htm") + ("logeqv" "f_logand.htm") + ("logical-pathname" "a_logica.htm") + ("logical-pathname-translations" "f_logica.htm") + ("logior" "f_logand.htm") + ("lognand" "f_logand.htm") + ("lognor" "f_logand.htm") + ("lognot" "f_logand.htm") + ("logorc1" "f_logand.htm") + ("logorc2" "f_logand.htm") + ("logtest" "f_logtes.htm") + ("logxor" "f_logand.htm") + ("long-float" "t_short_.htm") + ("long-float-epsilon" "v_short_.htm") + ("long-float-negative-epsilon" "v_short_.htm") + ("long-site-name" "f_short_.htm") + ("loop" "m_loop.htm") + ("loop-finish" "m_loop_f.htm") + ("lower-case-p" "f_upper_.htm") + ("machine-instance" "f_mach_i.htm") + ("machine-type" "f_mach_t.htm") + ("machine-version" "f_mach_v.htm") + ("macro-function" "f_macro_.htm") + ("macroexpand" "f_mexp_.htm") + ("macroexpand-1" "f_mexp_.htm") + ("macrolet" "s_flet_.htm") + ("make-array" "f_mk_ar.htm") + ("make-broadcast-stream" "f_mk_bro.htm") + ("make-concatenated-stream" "f_mk_con.htm") + ("make-condition" "f_mk_cnd.htm") + ("make-dispatch-macro-character" "f_mk_dis.htm") + ("make-echo-stream" "f_mk_ech.htm") + ("make-hash-table" "f_mk_has.htm") + ("make-instance" "f_mk_ins.htm") + ("make-instances-obsolete" "f_mk_i_1.htm") + ("make-list" "f_mk_lis.htm") + ("make-load-form" "f_mk_ld_.htm") + ("make-load-form-saving-slots" "f_mk_l_1.htm") + ("make-method" "m_call_m.htm") + ("make-package" "f_mk_pkg.htm") + ("make-pathname" "f_mk_pn.htm") + ("make-random-state" "f_mk_rnd.htm") + ("make-sequence" "f_mk_seq.htm") + ("make-string" "f_mk_stg.htm") + ("make-string-input-stream" "f_mk_s_1.htm") + ("make-string-output-stream" "f_mk_s_2.htm") + ("make-symbol" "f_mk_sym.htm") + ("make-synonym-stream" "f_mk_syn.htm") + ("make-two-way-stream" "f_mk_two.htm") + ("makunbound" "f_makunb.htm") + ("map" "f_map.htm") + ("map-into" "f_map_in.htm") + ("mapc" "f_mapc_.htm") + ("mapcan" "f_mapc_.htm") + ("mapcar" "f_mapc_.htm") + ("mapcon" "f_mapc_.htm") + ("maphash" "f_maphas.htm") + ("mapl" "f_mapc_.htm") + ("maplist" "f_mapc_.htm") + ("mask-field" "f_mask_f.htm") + ("max" "f_max_m.htm") + ("member" "a_member.htm") + ("member-if" "f_mem_m.htm") + ("member-if-not" "f_mem_m.htm") + ("merge" "f_merge.htm") + ("merge-pathnames" "f_merge_.htm") + ("method" "t_method.htm") + ("method-combination" "a_method.htm") + ("method-combination-error" "f_meth_1.htm") + ("method-qualifiers" "f_method.htm") + ("min" "f_max_m.htm") + ("minusp" "f_minusp.htm") + ("mismatch" "f_mismat.htm") + ("mod" "a_mod.htm") + ("most-negative-double-float" "v_most_1.htm") + ("most-negative-fixnum" "v_most_p.htm") + ("most-negative-long-float" "v_most_1.htm") + ("most-negative-short-float" "v_most_1.htm") + ("most-negative-single-float" "v_most_1.htm") + ("most-positive-double-float" "v_most_1.htm") + ("most-positive-fixnum" "v_most_p.htm") + ("most-positive-long-float" "v_most_1.htm") + ("most-positive-short-float" "v_most_1.htm") + ("most-positive-single-float" "v_most_1.htm") + ("muffle-warning" "a_muffle.htm") + ("multiple-value-bind" "m_multip.htm") + ("multiple-value-call" "s_multip.htm") + ("multiple-value-list" "m_mult_1.htm") + ("multiple-value-prog1" "s_mult_1.htm") + ("multiple-value-setq" "m_mult_2.htm") + ("multiple-values-limit" "v_multip.htm") + ("name-char" "f_name_c.htm") + ("namestring" "f_namest.htm") + ("nbutlast" "f_butlas.htm") + ("nconc" "f_nconc.htm") + ("next-method-p" "f_next_m.htm") + ("nil" "a_nil.htm") + ("nintersection" "f_isec_.htm") + ("ninth" "f_firstc.htm") + ("no-applicable-method" "f_no_app.htm") + ("no-next-method" "f_no_nex.htm") + ("not" "a_not.htm") + ("notany" "f_everyc.htm") + ("notevery" "f_everyc.htm") + ("notinline" "d_inline.htm") + ("nreconc" "f_revapp.htm") + ("nreverse" "f_revers.htm") + ("nset-difference" "f_set_di.htm") + ("nset-exclusive-or" "f_set_ex.htm") + ("nstring-capitalize" "f_stg_up.htm") + ("nstring-downcase" "f_stg_up.htm") + ("nstring-upcase" "f_stg_up.htm") + ("nsublis" "f_sublis.htm") + ("nsubst" "f_substc.htm") + ("nsubst-if" "f_substc.htm") + ("nsubst-if-not" "f_substc.htm") + ("nsubstitute" "f_sbs_s.htm") + ("nsubstitute-if" "f_sbs_s.htm") + ("nsubstitute-if-not" "f_sbs_s.htm") + ("nth" "f_nth.htm") + ("nth-value" "m_nth_va.htm") + ("nthcdr" "f_nthcdr.htm") + ("null" "a_null.htm") + ("number" "t_number.htm") + ("numberp" "f_nump.htm") + ("numerator" "f_numera.htm") + ("nunion" "f_unionc.htm") + ("oddp" "f_evenpc.htm") + ("open" "f_open.htm") + ("open-stream-p" "f_open_s.htm") + ("optimize" "d_optimi.htm") + ("or" "a_or.htm") + ("otherwise" "m_case_.htm") + ("output-stream-p" "f_in_stm.htm") + ("package" "t_pkg.htm") + ("package-error" "e_pkg_er.htm") + ("package-error-package" "f_pkg_er.htm") + ("package-name" "f_pkg_na.htm") + ("package-nicknames" "f_pkg_ni.htm") + ("package-shadowing-symbols" "f_pkg_sh.htm") + ("package-use-list" "f_pkg_us.htm") + ("package-used-by-list" "f_pkg__1.htm") + ("packagep" "f_pkgp.htm") + ("pairlis" "f_pairli.htm") + ("parse-error" "e_parse_.htm") + ("parse-integer" "f_parse_.htm") + ("parse-namestring" "f_pars_1.htm") + ("pathname" "a_pn.htm") + ("pathname-device" "f_pn_hos.htm") + ("pathname-directory" "f_pn_hos.htm") + ("pathname-host" "f_pn_hos.htm") + ("pathname-match-p" "f_pn_mat.htm") + ("pathname-name" "f_pn_hos.htm") + ("pathname-type" "f_pn_hos.htm") + ("pathname-version" "f_pn_hos.htm") + ("pathnamep" "f_pnp.htm") + ("peek-char" "f_peek_c.htm") + ("phase" "f_phase.htm") + ("pi" "v_pi.htm") + ("plusp" "f_minusp.htm") + ("pop" "m_pop.htm") + ("position" "f_pos_p.htm") + ("position-if" "f_pos_p.htm") + ("position-if-not" "f_pos_p.htm") + ("pprint" "f_wr_pr.htm") + ("pprint-dispatch" "f_ppr_di.htm") + ("pprint-exit-if-list-exhausted" "m_ppr_ex.htm") + ("pprint-fill" "f_ppr_fi.htm") + ("pprint-indent" "f_ppr_in.htm") + ("pprint-linear" "f_ppr_fi.htm") + ("pprint-logical-block" "m_ppr_lo.htm") + ("pprint-newline" "f_ppr_nl.htm") + ("pprint-pop" "m_ppr_po.htm") + ("pprint-tab" "f_ppr_ta.htm") + ("pprint-tabular" "f_ppr_fi.htm") + ("prin1" "f_wr_pr.htm") + ("prin1-to-string" "f_wr_to_.htm") + ("princ" "f_wr_pr.htm") + ("princ-to-string" "f_wr_to_.htm") + ("print" "f_wr_pr.htm") + ("print-not-readable" "e_pr_not.htm") + ("print-not-readable-object" "f_pr_not.htm") + ("print-object" "f_pr_obj.htm") + ("print-unreadable-object" "m_pr_unr.htm") + ("probe-file" "f_probe_.htm") + ("proclaim" "f_procla.htm") + ("prog" "m_prog_.htm") + ("prog*" "m_prog_.htm") + ("prog1" "m_prog1c.htm") + ("prog2" "m_prog1c.htm") + ("progn" "s_progn.htm") + ("program-error" "e_progra.htm") + ("progv" "s_progv.htm") + ("provide" "f_provid.htm") + ("psetf" "m_setf_.htm") + ("psetq" "m_psetq.htm") + ("push" "m_push.htm") + ("pushnew" "m_pshnew.htm") + ("quote" "s_quote.htm") + ("random" "f_random.htm") + ("random-state" "t_rnd_st.htm") + ("random-state-p" "f_rnd_st.htm") + ("rassoc" "f_rassoc.htm") + ("rassoc-if" "f_rassoc.htm") + ("rassoc-if-not" "f_rassoc.htm") + ("ratio" "t_ratio.htm") + ("rational" "a_ration.htm") + ("rationalize" "f_ration.htm") + ("rationalp" "f_rati_1.htm") + ("read" "f_rd_rd.htm") + ("read-byte" "f_rd_by.htm") + ("read-char" "f_rd_cha.htm") + ("read-char-no-hang" "f_rd_c_1.htm") + ("read-delimited-list" "f_rd_del.htm") + ("read-from-string" "f_rd_fro.htm") + ("read-line" "f_rd_lin.htm") + ("read-preserving-whitespace" "f_rd_rd.htm") + ("read-sequence" "f_rd_seq.htm") + ("reader-error" "e_rder_e.htm") + ("readtable" "t_rdtabl.htm") + ("readtable-case" "f_rdtabl.htm") + ("readtablep" "f_rdta_1.htm") + ("real" "t_real.htm") + ("realp" "f_realp.htm") + ("realpart" "f_realpa.htm") + ("reduce" "f_reduce.htm") + ("reinitialize-instance" "f_reinit.htm") + ("rem" "f_mod_r.htm") + ("remf" "m_remf.htm") + ("remhash" "f_remhas.htm") + ("remove" "f_rm_rm.htm") + ("remove-duplicates" "f_rm_dup.htm") + ("remove-if" "f_rm_rm.htm") + ("remove-if-not" "f_rm_rm.htm") + ("remove-method" "f_rm_met.htm") + ("remprop" "f_rempro.htm") + ("rename-file" "f_rn_fil.htm") + ("rename-package" "f_rn_pkg.htm") + ("replace" "f_replac.htm") + ("require" "f_provid.htm") + ("rest" "f_rest.htm") + ("restart" "t_rst.htm") + ("restart-bind" "m_rst_bi.htm") + ("restart-case" "m_rst_ca.htm") + ("restart-name" "f_rst_na.htm") + ("return" "m_return.htm") + ("return-from" "s_ret_fr.htm") + ("revappend" "f_revapp.htm") + ("reverse" "f_revers.htm") + ("room" "f_room.htm") + ("rotatef" "m_rotate.htm") + ("round" "f_floorc.htm") + ("row-major-aref" "f_row_ma.htm") + ("rplaca" "f_rplaca.htm") + ("rplacd" "f_rplaca.htm") + ("safety" "d_optimi.htm") + ("satisfies" "t_satisf.htm") + ("sbit" "f_bt_sb.htm") + ("scale-float" "f_dec_fl.htm") + ("schar" "f_char_.htm") + ("search" "f_search.htm") + ("second" "f_firstc.htm") + ("sequence" "t_seq.htm") + ("serious-condition" "e_seriou.htm") + ("set" "f_set.htm") + ("set-difference" "f_set_di.htm") + ("set-dispatch-macro-character" "f_set__1.htm") + ("set-exclusive-or" "f_set_ex.htm") + ("set-macro-character" "f_set_ma.htm") + ("set-pprint-dispatch" "f_set_pp.htm") + ("set-syntax-from-char" "f_set_sy.htm") + ("setf" "a_setf.htm") + ("setq" "s_setq.htm") + ("seventh" "f_firstc.htm") + ("shadow" "f_shadow.htm") + ("shadowing-import" "f_shdw_i.htm") + ("shared-initialize" "f_shared.htm") + ("shiftf" "m_shiftf.htm") + ("short-float" "t_short_.htm") + ("short-float-epsilon" "v_short_.htm") + ("short-float-negative-epsilon" "v_short_.htm") + ("short-site-name" "f_short_.htm") + ("signal" "f_signal.htm") + ("signed-byte" "t_sgn_by.htm") + ("signum" "f_signum.htm") + ("simple-array" "t_smp_ar.htm") + ("simple-base-string" "t_smp_ba.htm") + ("simple-bit-vector" "t_smp_bt.htm") + ("simple-bit-vector-p" "f_smp_bt.htm") + ("simple-condition" "e_smp_cn.htm") + ("simple-condition-format-arguments" "f_smp_cn.htm") + ("simple-condition-format-control" "f_smp_cn.htm") + ("simple-error" "e_smp_er.htm") + ("simple-string" "t_smp_st.htm") + ("simple-string-p" "f_smp_st.htm") + ("simple-type-error" "e_smp_tp.htm") + ("simple-vector" "t_smp_ve.htm") + ("simple-vector-p" "f_smp_ve.htm") + ("simple-warning" "e_smp_wa.htm") + ("sin" "f_sin_c.htm") + ("single-float" "t_short_.htm") + ("single-float-epsilon" "v_short_.htm") + ("single-float-negative-epsilon" "v_short_.htm") + ("sinh" "f_sinh_.htm") + ("sixth" "f_firstc.htm") + ("sleep" "f_sleep.htm") + ("slot-boundp" "f_slt_bo.htm") + ("slot-exists-p" "f_slt_ex.htm") + ("slot-makunbound" "f_slt_ma.htm") + ("slot-missing" "f_slt_mi.htm") + ("slot-unbound" "f_slt_un.htm") + ("slot-value" "f_slt_va.htm") + ("software-type" "f_sw_tpc.htm") + ("software-version" "f_sw_tpc.htm") + ("some" "f_everyc.htm") + ("sort" "f_sort_.htm") + ("space" "d_optimi.htm") + ("special" "d_specia.htm") + ("special-operator-p" "f_specia.htm") + ("speed" "d_optimi.htm") + ("sqrt" "f_sqrt_.htm") + ("stable-sort" "f_sort_.htm") + ("standard" "07_ffb.htm") + ("standard-char" "t_std_ch.htm") + ("standard-char-p" "f_std_ch.htm") + ("standard-class" "t_std_cl.htm") + ("standard-generic-function" "t_std_ge.htm") + ("standard-method" "t_std_me.htm") + ("standard-object" "t_std_ob.htm") + ("step" "m_step.htm") + ("storage-condition" "e_storag.htm") + ("store-value" "a_store_.htm") + ("stream" "t_stream.htm") + ("stream-element-type" "f_stm_el.htm") + ("stream-error" "e_stm_er.htm") + ("stream-error-stream" "f_stm_er.htm") + ("stream-external-format" "f_stm_ex.htm") + ("streamp" "f_stmp.htm") + ("string" "a_string.htm") + ("string-capitalize" "f_stg_up.htm") + ("string-downcase" "f_stg_up.htm") + ("string-equal" "f_stgeq_.htm") + ("string-greaterp" "f_stgeq_.htm") + ("string-left-trim" "f_stg_tr.htm") + ("string-lessp" "f_stgeq_.htm") + ("string-not-equal" "f_stgeq_.htm") + ("string-not-greaterp" "f_stgeq_.htm") + ("string-not-lessp" "f_stgeq_.htm") + ("string-right-trim" "f_stg_tr.htm") + ("string-stream" "t_stg_st.htm") + ("string-trim" "f_stg_tr.htm") + ("string-upcase" "f_stg_up.htm") + ("string/=" "f_stgeq_.htm") + ("string<" "f_stgeq_.htm") + ("string<=" "f_stgeq_.htm") + ("string=" "f_stgeq_.htm") + ("string>" "f_stgeq_.htm") + ("string>=" "f_stgeq_.htm") + ("stringp" "f_stgp.htm") + ("structure" "f_docume.htm") + ("structure-class" "t_stu_cl.htm") + ("structure-object" "t_stu_ob.htm") + ("style-warning" "e_style_.htm") + ("sublis" "f_sublis.htm") + ("subseq" "f_subseq.htm") + ("subsetp" "f_subset.htm") + ("subst" "f_substc.htm") + ("subst-if" "f_substc.htm") + ("subst-if-not" "f_substc.htm") + ("substitute" "f_sbs_s.htm") + ("substitute-if" "f_sbs_s.htm") + ("substitute-if-not" "f_sbs_s.htm") + ("subtypep" "f_subtpp.htm") + ("svref" "f_svref.htm") + ("sxhash" "f_sxhash.htm") + ("symbol" "t_symbol.htm") + ("symbol-function" "f_symb_1.htm") + ("symbol-macrolet" "s_symbol.htm") + ("symbol-name" "f_symb_2.htm") + ("symbol-package" "f_symb_3.htm") + ("symbol-plist" "f_symb_4.htm") + ("symbol-value" "f_symb_5.htm") + ("symbolp" "f_symbol.htm") + ("synonym-stream" "t_syn_st.htm") + ("synonym-stream-symbol" "f_syn_st.htm") + ("t" "a_t.htm") + ("tagbody" "s_tagbod.htm") + ("tailp" "f_ldiffc.htm") + ("tan" "f_sin_c.htm") + ("tanh" "f_sinh_.htm") + ("tenth" "f_firstc.htm") + ("terpri" "f_terpri.htm") + ("the" "s_the.htm") + ("third" "f_firstc.htm") + ("throw" "s_throw.htm") + ("time" "m_time.htm") + ("trace" "m_tracec.htm") + ("translate-logical-pathname" "f_tr_log.htm") + ("translate-pathname" "f_tr_pn.htm") + ("tree-equal" "f_tree_e.htm") + ("truename" "f_tn.htm") + ("truncate" "f_floorc.htm") + ("two-way-stream" "t_two_wa.htm") + ("two-way-stream-input-stream" "f_two_wa.htm") + ("two-way-stream-output-stream" "f_two_wa.htm") + ("type" "a_type.htm") + ("type-error" "e_tp_err.htm") + ("type-error-datum" "f_tp_err.htm") + ("type-error-expected-type" "f_tp_err.htm") + ("type-of" "f_tp_of.htm") + ("typecase" "m_tpcase.htm") + ("typep" "f_typep.htm") + ("unbound-slot" "e_unboun.htm") + ("unbound-slot-instance" "f_unboun.htm") + ("unbound-variable" "e_unbo_1.htm") + ("undefined-function" "e_undefi.htm") + ("unexport" "f_unexpo.htm") + ("unintern" "f_uninte.htm") + ("union" "f_unionc.htm") + ("unless" "m_when_.htm") + ("unread-char" "f_unrd_c.htm") + ("unsigned-byte" "t_unsgn_.htm") + ("untrace" "m_tracec.htm") + ("unuse-package" "f_unuse_.htm") + ("unwind-protect" "s_unwind.htm") + ("update-instance-for-different-class" "f_update.htm") + ("update-instance-for-redefined-class" "f_upda_1.htm") + ("upgraded-array-element-type" "f_upgr_1.htm") + ("upgraded-complex-part-type" "f_upgrad.htm") + ("upper-case-p" "f_upper_.htm") + ("use-package" "f_use_pk.htm") + ("use-value" "a_use_va.htm") + ("user-homedir-pathname" "f_user_h.htm") + ("values" "a_values.htm") + ("values-list" "f_vals_l.htm") + ("variable" "f_docume.htm") + ("vector" "a_vector.htm") + ("vector-pop" "f_vec_po.htm") + ("vector-push" "f_vec_ps.htm") + ("vector-push-extend" "f_vec_ps.htm") + ("vectorp" "f_vecp.htm") + ("warn" "f_warn.htm") + ("warning" "e_warnin.htm") + ("when" "m_when_.htm") + ("wild-pathname-p" "f_wild_p.htm") + ("with-accessors" "m_w_acce.htm") + ("with-compilation-unit" "m_w_comp.htm") + ("with-condition-restarts" "m_w_cnd_.htm") + ("with-hash-table-iterator" "m_w_hash.htm") + ("with-input-from-string" "m_w_in_f.htm") + ("with-open-file" "m_w_open.htm") + ("with-open-stream" "m_w_op_1.htm") + ("with-output-to-string" "m_w_out_.htm") + ("with-package-iterator" "m_w_pkg_.htm") + ("with-simple-restart" "m_w_smp_.htm") + ("with-slots" "m_w_slts.htm") + ("with-standard-io-syntax" "m_w_std_.htm") + ("write" "f_wr_pr.htm") + ("write-byte" "f_wr_by.htm") + ("write-char" "f_wr_cha.htm") + ("write-line" "f_wr_stg.htm") + ("write-sequence" "f_wr_seq.htm") + ("write-string" "f_wr_stg.htm") + ("write-to-string" "f_wr_to_.htm") + ("y-or-n-p" "f_y_or_n.htm") + ("yes-or-no-p" "f_y_or_n.htm") + ("zerop" "f_zerop.htm")))) + +;;; FORMAT character lookup by Frode Vatvedt Fjeld frodef@acm.org 20030902 +;;; +;;; adjusted for ILISP by Nikodemus Siivola 20030903 + +(defvar common-lisp-hyperspec-format-history nil + "History of format characters looked up in the Common Lisp HyperSpec.") + +(defvar common-lisp-hyperspec-format-characters (make-vector 67 0)) + + +(defun common-lisp-hyperspec-section-6.0 (indices) + (let ((string (format "%sBody/%s_" + common-lisp-hyperspec-root + (let ((base (pop indices))) + (if (< base 10) + (format "0%s" base) + base))))) + (concat string + (mapconcat (lambda (n) + (make-string 1 (+ ?a (- n 1)))) + indices + "") + ".htm"))) + +(defun common-lisp-hyperspec-section-4.0 (indices) + (let ((string (format "%sBody/sec_" + common-lisp-hyperspec-root))) + (concat string + (mapconcat (lambda (n) + (format "%d" n)) + indices + "-") + ".html"))) + +(defvar common-lisp-hyperspec-section-fun 'common-lisp-hyperspec-section-6.0) + +(defun common-lisp-hyperspec-section (indices) + (funcall common-lisp-hyperspec-section-fun indices)) + +(defun common-lisp-hyperspec-format (character-name) + (interactive + (list (let ((char-at-point + (ignore-errors (char-to-string (char-after (point)))))) + (if (and char-at-point + (intern-soft (upcase char-at-point) + common-lisp-hyperspec-format-characters)) + char-at-point + (completing-read + "Look up format control character in Common Lisp HyperSpec: " + common-lisp-hyperspec-format-characters nil #'boundp + nil nil 'common-lisp-hyperspec-format-history))))) + (maplist (lambda (entry) + (browse-url (common-lisp-hyperspec-section (car entry)))) + (let ((symbol (intern-soft character-name + common-lisp-hyperspec-format-characters))) + (if (and symbol (boundp symbol)) + (symbol-value symbol) + (error "The symbol `%s' is not defined in Common Lisp" + character-name))))) + +(eval-when (load eval) + (defalias 'hyperspec-lookup-format 'common-lisp-hyperspec-format)) + +(mapcar (lambda (entry) + (let ((symbol (intern (car entry) + common-lisp-hyperspec-format-characters))) + (if (boundp symbol) + (pushnew (cadr entry) (symbol-value symbol) :test 'equal) + (set symbol (cdr entry)))) + (when (and (= 1 (length (car entry))) + (not (string-equal (car entry) (upcase (car entry))))) + (let ((symbol (intern (upcase (car entry)) + common-lisp-hyperspec-format-characters))) + (if (boundp symbol) + (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)) + ("o" (22 3 2 4)) ("O: Octal" (22 3 2 4)) + ("x" (22 3 2 5)) ("X: Hexadecimal" (22 3 2 5)) + ("f" (22 3 3 1)) ("F: Fixed-Format Floating-Point" (22 3 3 1)) + ("e" (22 3 3 2)) ("E: Exponential Floating-Point" (22 3 3 2)) + ("g" (22 3 3 3)) ("G: General Floating-Point" (22 3 3 3)) + ("$" (22 3 3 4)) ("Dollarsign: Monetary Floating-Point" (22 3 3 4)) + ("a" (22 3 4 1)) ("A: Aesthetic" (22 3 4 1)) + ("s" (22 3 4 2)) ("S: Standard" (22 3 4 2)) + ("w" (22 3 4 3)) ("W: Write" (22 3 4 3)) + ("_" (22 3 5 1)) ("Underscore: Conditional Newline" (22 3 5 1)) + ("<" (22 3 5 2)) ("Less-Than-Sign: Logical Block" (22 3 5 2)) + ("i" (22 3 5 3)) ("I: Indent" (22 3 5 3)) + ("/" (22 3 5 4)) ("Slash: Call Function" (22 3 5 4)) + ("t" (22 3 6 1)) ("T: Tabulate" (22 3 6 1)) + ("<" (22 3 6 2)) ("Less-Than-Sign: Justification" (22 3 6 2)) + (">" (22 3 6 3)) ("Greater-Than-Sign: End of Justification" (22 3 6 3)) + ("*" (22 3 7 1)) ("Asterisk: Go-To" (22 3 7 1)) + ("[" (22 3 7 2)) ("Left-Bracket: Conditional Expression" (22 3 7 2)) + ("]" (22 3 7 3)) ("Right-Bracket: End of Conditional Expression" (22 3 7 3)) + ("{" (22 3 7 4)) ("Left-Brace: Iteration" (22 3 7 4)) + ("}" (22 3 7 5)) ("Right-Brace: End of Iteration" (22 3 7 5)) + ("?" (22 3 7 6)) ("Question-Mark: Recursive Processing" (22 3 7 6)) + ("(" (22 3 8 1)) ("Left-Paren: Case Conversion" (22 3 8 1)) + (")" (22 3 8 2)) ("Right-Paren: End of Case Conversion" (22 3 8 2)) + ("p" (22 3 8 3)) ("P: Plural" (22 3 8-3)) + (";" (22 3 9 1)) ("Semicolon: Clause Separator" (22 3 9 1)) + ("^" (22 3 9 2)) ("Circumflex: Escape Upward" (22 3 9 2)) + ("Newline: Ignored Newline" (22 3 9 3)) + ("Nesting of FORMAT Operations" (22 3 10 1)) + ("Missing and Additional FORMAT Arguments" (22 3 10 2)) + ("Additional FORMAT Parameters" (22 3 10 3)))) + +(defvar common-lisp-glossary-fun 'common-lisp-glossary-6.0) + +(defun common-lisp-glossary-6.0 (string) + (format "%sBody/26_glo_%s.htm#%s" + common-lisp-hyperspec-root + (let ((char (string-to-char string))) + (if (and (<= ?a char) + (<= char ?z)) + (make-string 1 char) + "9")) + (subst-char-in-string ?\ ?_ string))) + +(defun common-lisp-glossary-4.0 (string) + (format "%sBody/glo_%s.html#%s" + common-lisp-hyperspec-root + (let ((char (string-to-char string))) + (if (and (<= ?a char) + (<= char ?z)) + (make-string 1 char) + "9")) + (subst-char-in-string ?\ ?_ string))) + +(defvar common-lisp-hyperspec-issuex-table nil + "The HyperSpec IssueX table file. If you copy the HyperSpec to your +local system, set this variable to the location of the Issue +cross-references table which is usually "Map_IssX.txt" or +"Issue-Cross-Refs.text".") + +(defvar common-lisp-hyperspec-issuex-symbols (make-vector 67 0)) + +(if common-lisp-hyperspec-issuex-table + (let ((index-buffer (find-file-noselect common-lisp-hyperspec-issuex-table))) + (labels ((get-one-line () + (prog1 + (delete* ?\n (thing-at-point 'line)) + (forward-line)))) + (save-excursion + (set-buffer index-buffer) + (goto-char (point-min)) + (while (< (point) (point-max)) + (let* ((symbol (intern (downcase (get-one-line)) + common-lisp-hyperspec-issuex-symbols)) + (relative-url (get-one-line))) + (set symbol (subseq relative-url + (1+ (position ?/ relative-url :from-end t))))))))) + (mapcar + (lambda (entry) + (let ((symbol (intern (car entry) common-lisp-hyperspec-issuex-symbols))) + (set symbol (cadr entry)))) + '(("&environment-binding-order:first" "iss001.htm") + ("access-error-name" "iss002.htm") + ("adjust-array-displacement" "iss003.htm") + ("adjust-array-fill-pointer" "iss004.htm") + ("adjust-array-not-adjustable:implicit-copy" "iss005.htm") + ("allocate-instance:add" "iss006.htm") + ("allow-local-inline:inline-notinline" "iss007.htm") + ("allow-other-keys-nil:permit" "iss008.htm") + ("aref-1d" "iss009.htm") + ("argument-mismatch-error-again:consistent" "iss010.htm") + ("argument-mismatch-error-moon:fix" "iss011.htm") + ("argument-mismatch-error:more-clarifications" "iss012.htm") + ("arguments-underspecified:specify" "iss013.htm") + ("array-dimension-limit-implications:all-fixnum" "iss014.htm") + ("array-type-element-type-semantics:unify-upgrading" "iss015.htm") + ("assert-error-type:error" "iss016.htm") + ("assoc-rassoc-if-key" "iss017.htm") + ("assoc-rassoc-if-key:yes" "iss018.htm") + ("boa-aux-initialization:error-on-read" "iss019.htm") + ("break-on-warnings-obsolete:remove" "iss020.htm") + ("broadcast-stream-return-values:clarify-minimally" "iss021.htm") + ("butlast-negative:should-signal" "iss022.htm") + ("change-class-initargs:permit" "iss023.htm") + ("char-name-case:x3j13-mar-91" "iss024.htm") + ("character-loose-ends:fix" "iss025.htm") + ("character-proposal:2" "iss026.htm") + ("character-proposal:2-1-1" "iss027.htm") + ("character-proposal:2-1-2" "iss028.htm") + ("character-proposal:2-2-1" "iss029.htm") + ("character-proposal:2-3-1" "iss030.htm") + ("character-proposal:2-3-2" "iss031.htm") + ("character-proposal:2-3-3" "iss032.htm") + ("character-proposal:2-3-4" "iss033.htm") + ("character-proposal:2-3-5" "iss034.htm") + ("character-proposal:2-3-6" "iss035.htm") + ("character-proposal:2-4-1" "iss036.htm") + ("character-proposal:2-4-2" "iss037.htm") + ("character-proposal:2-4-3" "iss038.htm") + ("character-proposal:2-5-2" "iss039.htm") + ("character-proposal:2-5-6" "iss040.htm") + ("character-proposal:2-5-7" "iss041.htm") + ("character-proposal:2-6-1" "iss042.htm") + ("character-proposal:2-6-2" "iss043.htm") + ("character-proposal:2-6-3" "iss044.htm") + ("character-proposal:2-6-5" "iss045.htm") + ("character-vs-char:less-inconsistent-short" "iss046.htm") + ("class-object-specializer:affirm" "iss047.htm") + ("clos-conditions-again:allow-subset" "iss048.htm") + ("clos-conditions:integrate" "iss049.htm") + ("clos-error-checking-order:no-applicable-method-first" "iss050.htm") + ("clos-macro-compilation:minimal" "iss051.htm") + ("close-constructed-stream:argument-stream-only" "iss052.htm") + ("closed-stream-operations:allow-inquiry" "iss053.htm") + ("coercing-setf-name-to-function:all-function-names" "iss054.htm") + ("colon-number" "iss055.htm") + ("common-features:specify" "iss056.htm") + ("common-type:remove" "iss057.htm") + ("compile-argument-problems-again:fix" "iss058.htm") + ("compile-file-handling-of-top-level-forms:clarify" "iss059.htm") + ("compile-file-output-file-defaults:input-file" "iss060.htm") + ("compile-file-package" "iss061.htm") + ("compile-file-pathname-arguments:make-consistent" "iss062.htm") + ("compile-file-symbol-handling:new-require-consistency" "iss063.htm") + ("compiled-function-requirements:tighten" "iss064.htm") + ("compiler-diagnostics:use-handler" "iss065.htm") + ("compiler-let-confusion:eliminate" "iss066.htm") + ("compiler-verbosity:like-load" "iss067.htm") + ("compiler-warning-stream" "iss068.htm") + ("complex-atan-branch-cut:tweak" "iss069.htm") + ("complex-atanh-bogus-formula:tweak-more" "iss070.htm") + ("complex-rational-result:extend" "iss071.htm") + ("compute-applicable-methods:generic" "iss072.htm") + ("concatenate-sequence:signal-error" "iss073.htm") + ("condition-accessors-setfable:no" "iss074.htm") + ("condition-restarts:buggy" "iss075.htm") + ("condition-restarts:permit-association" "iss076.htm") + ("condition-slots:hidden" "iss077.htm") + ("cons-type-specifier:add" "iss078.htm") + ("constant-circular-compilation:yes" "iss079.htm") + ("constant-collapsing:generalize" "iss080.htm") + ("constant-compilable-types:specify" "iss081.htm") + ("constant-function-compilation:no" "iss082.htm") + ("constant-modification:disallow" "iss083.htm") + ("constantp-definition:intentional" "iss084.htm") + ("constantp-environment:add-arg" "iss085.htm") + ("contagion-on-numerical-comparisons:transitive" "iss086.htm") + ("copy-symbol-copy-plist:copy-list" "iss087.htm") + ("copy-symbol-print-name:equal" "iss088.htm") + ("data-io:add-support" "iss089.htm") + ("data-types-hierarchy-underspecified" "iss090.htm") + ("debugger-hook-vs-break:clarify" "iss091.htm") + ("declaration-scope:no-hoisting" "iss092.htm") + ("declare-array-type-element-references:restrictive" "iss093.htm") + ("declare-function-ambiguity:delete-ftype-abbreviation" "iss094.htm") + ("declare-macros:flush" "iss095.htm") + ("declare-type-free:lexical" "iss096.htm") + ("decls-and-doc" "iss097.htm") + ("decode-universal-time-daylight:like-encode" "iss098.htm") + ("defconstant-special:no" "iss099.htm") + ("defgeneric-declare:allow-multiple" "iss100.htm") + ("define-compiler-macro:x3j13-nov89" "iss101.htm") + ("define-condition-syntax:incompatibly-more-like-defclass+emphasize-read-only" "iss102.htm") + ("define-method-combination-behavior:clarify" "iss103.htm") + ("defining-macros-non-top-level:allow" "iss104.htm") + ("defmacro-block-scope:excludes-bindings" "iss105.htm") + ("defmacro-lambda-list:tighten-description" "iss106.htm") + ("defmethod-declaration-scope:corresponds-to-bindings" "iss107.htm") + ("defpackage:addition" "iss108.htm") + ("defstruct-constructor-key-mixture:allow-key" "iss109.htm") + ("defstruct-constructor-options:explicit" "iss110.htm") + ("defstruct-constructor-slot-variables:not-bound" "iss111.htm") + ("defstruct-copier-argument-type:restrict" "iss112.htm") + ("defstruct-copier:argument-type" "iss113.htm") + ("defstruct-default-value-evaluation:iff-needed" "iss114.htm") + ("defstruct-include-deftype:explicitly-undefined" "iss115.htm") + ("defstruct-print-function-again:x3j13-mar-93" "iss116.htm") + ("defstruct-print-function-inheritance:yes" "iss117.htm") + ("defstruct-redefinition:error" "iss118.htm") + ("defstruct-slots-constraints-name:duplicates-error" "iss119.htm") + ("defstruct-slots-constraints-number" "iss120.htm") + ("deftype-destructuring:yes" "iss121.htm") + ("deftype-key:allow" "iss122.htm") + ("defvar-documentation:unevaluated" "iss123.htm") + ("defvar-init-time:not-delayed" "iss124.htm") + ("defvar-initialization:conservative" "iss125.htm") + ("deprecation-position:limited" "iss126.htm") + ("describe-interactive:no" "iss127.htm") + ("describe-underspecified:describe-object" "iss128.htm") + ("destructive-operations:specify" "iss129.htm") + ("destructuring-bind:new-macro" "iss130.htm") + ("disassemble-side-effect:do-not-install" "iss131.htm") + ("displaced-array-predicate:add" "iss132.htm") + ("do-symbols-block-scope:entire-form" "iss133.htm") + ("do-symbols-duplicates" "iss134.htm") + ("documentation-function-bugs:fix" "iss135.htm") + ("documentation-function-tangled:require-argument" "iss136.htm") + ("dotimes-ignore:x3j13-mar91" "iss137.htm") + ("dotted-list-arguments:clarify" "iss138.htm") + ("dotted-macro-forms:allow" "iss139.htm") + ("dribble-technique" "iss140.htm") + ("dynamic-extent-function:extend" "iss141.htm") + ("dynamic-extent:new-declaration" "iss142.htm") + ("equal-structure:maybe-status-quo" "iss143.htm") + ("error-terminology-warning:might" "iss144.htm") + ("eval-other:self-evaluate" "iss145.htm") + ("eval-top-level:load-like-compile-file" "iss146.htm") + ("eval-when-non-top-level:generalize-eval-new-keywords" "iss147.htm") + ("eval-when-obsolete-keywords:x3j13-mar-1993" "iss148.htm") + ("evalhook-step-confusion:fix" "iss149.htm") + ("evalhook-step-confusion:x3j13-nov-89" "iss150.htm") + ("exit-extent-and-condition-system:like-dynamic-bindings" "iss151.htm") + ("exit-extent:minimal" "iss152.htm") + ("expt-ratio:p.211" "iss153.htm") + ("extensions-position:documentation" "iss154.htm") + ("external-format-for-every-file-connection:minimum" "iss155.htm") + ("extra-return-values:no" "iss156.htm") + ("file-open-error:signal-file-error" "iss157.htm") + ("fixnum-non-portable:tighten-definition" "iss158.htm") + ("flet-declarations" "iss159.htm") + ("flet-declarations:allow" "iss160.htm") + ("flet-implicit-block:yes" "iss161.htm") + ("float-underflow:add-variables" "iss162.htm") + ("floating-point-condition-names:x3j13-nov-89" "iss163.htm") + ("format-atsign-colon" "iss164.htm") + ("format-colon-uparrow-scope" "iss165.htm") + ("format-comma-interval" "iss166.htm") + ("format-e-exponent-sign:force-sign" "iss167.htm") + ("format-op-c" "iss168.htm") + ("format-pretty-print:yes" "iss169.htm") + ("format-string-arguments:specify" "iss170.htm") + ("function-call-evaluation-order:more-unspecified" "iss171.htm") + ("function-composition:jan89-x3j13" "iss172.htm") + ("function-definition:jan89-x3j13" "iss173.htm") + ("function-name:large" "iss174.htm") + ("function-type" "iss175.htm") + ("function-type-argument-type-semantics:restrictive" "iss176.htm") + ("function-type-key-name:specify-keyword" "iss177.htm") + ("function-type-rest-list-element:use-actual-argument-type" "iss178.htm") + ("function-type:x3j13-march-88" "iss179.htm") + ("generalize-pretty-printer:unify" "iss180.htm") + ("generic-flet-poorly-designed:delete" "iss181.htm") + ("gensym-name-stickiness:like-teflon" "iss182.htm") + ("gentemp-bad-idea:deprecate" "iss183.htm") + ("get-macro-character-readtable:nil-standard" "iss184.htm") + ("get-setf-method-environment:add-arg" "iss185.htm") + ("hash-table-access:x3j13-mar-89" "iss186.htm") + ("hash-table-key-modification:specify" "iss187.htm") + ("hash-table-package-generators:add-with-wrapper" "iss188.htm") + ("hash-table-rehash-size-integer" "iss189.htm") + ("hash-table-size:intended-entries" "iss190.htm") + ("hash-table-tests:add-equalp" "iss191.htm") + ("ieee-atan-branch-cut:split" "iss192.htm") + ("ignore-use-terminology:value-only" "iss193.htm") + ("import-setf-symbol-package" "iss194.htm") + ("in-package-functionality:mar89-x3j13" "iss195.htm") + ("in-syntax:minimal" "iss196.htm") + ("initialization-function-keyword-checking" "iss197.htm") + ("iso-compatibility:add-substrate" "iss198.htm") + ("jun90-trivial-issues:11" "iss199.htm") + ("jun90-trivial-issues:14" "iss200.htm") + ("jun90-trivial-issues:24" "iss201.htm") + ("jun90-trivial-issues:25" "iss202.htm") + ("jun90-trivial-issues:27" "iss203.htm") + ("jun90-trivial-issues:3" "iss204.htm") + ("jun90-trivial-issues:4" "iss205.htm") + ("jun90-trivial-issues:5" "iss206.htm") + ("jun90-trivial-issues:9" "iss207.htm") + ("keyword-argument-name-package:any" "iss208.htm") + ("last-n" "iss209.htm") + ("lcm-no-arguments:1" "iss210.htm") + ("lexical-construct-global-definition:undefined" "iss211.htm") + ("lisp-package-name:common-lisp" "iss212.htm") + ("lisp-symbol-redefinition-again:more-fixes" "iss213.htm") + ("lisp-symbol-redefinition:mar89-x3j13" "iss214.htm") + ("load-objects:make-load-form" "iss215.htm") + ("load-time-eval:r**2-new-special-form" "iss216.htm") + ("load-time-eval:r**3-new-special-form" "iss217.htm") + ("load-truename:new-pathname-variables" "iss218.htm") + ("locally-top-level:special-form" "iss219.htm") + ("loop-and-discrepancy:no-reiteration" "iss220.htm") + ("loop-for-as-on-typo:fix-typo" "iss221.htm") + ("loop-initform-environment:partial-interleaving-vague" "iss222.htm") + ("loop-miscellaneous-repairs:fix" "iss223.htm") + ("loop-named-block-nil:override" "iss224.htm") + ("loop-present-symbols-typo:flush-wrong-words" "iss225.htm") + ("loop-syntax-overhaul:repair" "iss226.htm") + ("macro-as-function:disallow" "iss227.htm") + ("macro-declarations:make-explicit" "iss228.htm") + ("macro-environment-extent:dynamic" "iss229.htm") + ("macro-function-environment" "iss230.htm") + ("macro-function-environment:yes" "iss231.htm") + ("macro-subforms-top-level-p:add-constraints" "iss232.htm") + ("macroexpand-hook-default:explicitly-vague" "iss233.htm") + ("macroexpand-hook-initial-value:implementation-dependent" "iss234.htm") + ("macroexpand-return-value:true" "iss235.htm") + ("make-load-form-confusion:rewrite" "iss236.htm") + ("make-load-form-saving-slots:no-initforms" "iss237.htm") + ("make-package-use-default:implementation-dependent" "iss238.htm") + ("map-into:add-function" "iss239.htm") + ("mapping-destructive-interaction:explicitly-vague" "iss240.htm") + ("metaclass-of-system-class:unspecified" "iss241.htm") + ("method-combination-arguments:clarify" "iss242.htm") + ("method-initform:forbid-call-next-method" "iss243.htm") + ("muffle-warning-condition-argument" "iss244.htm") + ("multiple-value-setq-order:like-setf-of-values" "iss245.htm") + ("multiple-values-limit-on-variables:undefined" "iss246.htm") + ("nintersection-destruction" "iss247.htm") + ("nintersection-destruction:revert" "iss248.htm") + ("not-and-null-return-value:x3j13-mar-93" "iss249.htm") + ("nth-value:add" "iss250.htm") + ("optimize-debug-info:new-quality" "iss251.htm") + ("package-clutter:reduce" "iss252.htm") + ("package-deletion:new-function" "iss253.htm") + ("package-function-consistency:more-permissive" "iss254.htm") + ("parse-error-stream:split-types" "iss255.htm") + ("pathname-component-case:keyword-argument" "iss256.htm") + ("pathname-component-value:specify" "iss257.htm") + ("pathname-host-parsing:recognize-logical-host-names" "iss258.htm") + ("pathname-logical:add" "iss259.htm") + ("pathname-print-read:sharpsign-p" "iss260.htm") + ("pathname-stream" "iss261.htm") + ("pathname-stream:files-or-synonym" "iss262.htm") + ("pathname-subdirectory-list:new-representation" "iss263.htm") + ("pathname-symbol" "iss264.htm") + ("pathname-syntax-error-time:explicitly-vague" "iss265.htm") + ("pathname-unspecific-component:new-token" "iss266.htm") + ("pathname-wild:new-functions" "iss267.htm") + ("peek-char-read-char-echo:first-read-char" "iss268.htm") + ("plist-duplicates:allow" "iss269.htm") + ("pretty-print-interface" "iss270.htm") + ("princ-readably:x3j13-dec-91" "iss271.htm") + ("print-case-behavior:clarify" "iss272.htm") + ("print-case-print-escape-interaction:vertical-bar-rule-no-upcase" "iss273.htm") + ("print-circle-shared:respect-print-circle" "iss274.htm") + ("print-circle-structure:user-functions-work" "iss275.htm") + ("print-readably-behavior:clarify" "iss276.htm") + ("printer-whitespace:just-one-space" "iss277.htm") + ("proclaim-etc-in-compile-file:new-macro" "iss278.htm") + ("push-evaluation-order:first-item" "iss279.htm") + ("push-evaluation-order:item-first" "iss280.htm") + ("pushnew-store-required:unspecified" "iss281.htm") + ("quote-semantics:no-copying" "iss282.htm") + ("range-of-count-keyword:nil-or-integer" "iss283.htm") + ("range-of-start-and-end-parameters:integer-and-integer-nil" "iss284.htm") + ("read-and-write-bytes:new-functions" "iss285.htm") + ("read-case-sensitivity:readtable-keywords" "iss286.htm") + ("read-modify-write-evaluation-order:delayed-access-stores" "iss287.htm") + ("read-suppress-confusing:generalize" "iss288.htm") + ("reader-error:new-type" "iss289.htm") + ("real-number-type:x3j13-mar-89" "iss290.htm") + ("recursive-deftype:explicitly-vague" "iss291.htm") + ("reduce-argument-extraction" "iss292.htm") + ("remf-destruction-unspecified:x3j13-mar-89" "iss293.htm") + ("require-pathname-defaults-again:x3j13-dec-91" "iss294.htm") + ("require-pathname-defaults-yet-again:restore-argument" "iss295.htm") + ("require-pathname-defaults:eliminate" "iss296.htm") + ("rest-list-allocation:may-share" "iss297.htm") + ("result-lists-shared:specify" "iss298.htm") + ("return-values-unspecified:specify" "iss299.htm") + ("room-default-argument:new-value" "iss300.htm") + ("self-modifying-code:forbid" "iss301.htm") + ("sequence-type-length:must-match" "iss302.htm") + ("setf-apply-expansion:ignore-expander" "iss303.htm") + ("setf-find-class:allow-nil" "iss304.htm") + ("setf-functions-again:minimal-changes" "iss305.htm") + ("setf-get-default:evaluated-but-ignored" "iss306.htm") + ("setf-macro-expansion:last" "iss307.htm") + ("setf-method-vs-setf-method:rename-old-terms" "iss308.htm") + ("setf-multiple-store-variables:allow" "iss309.htm") + ("setf-of-apply:only-aref-and-friends" "iss310.htm") + ("setf-of-values:add" "iss311.htm") + ("setf-sub-methods:delayed-access-stores" "iss312.htm") + ("shadow-already-present" "iss313.htm") + ("shadow-already-present:works" "iss314.htm") + ("sharp-comma-confusion:remove" "iss315.htm") + ("sharp-o-foobar:consequences-undefined" "iss316.htm") + ("sharp-star-delimiter:normal-delimiter" "iss317.htm") + ("sharpsign-plus-minus-package:keyword" "iss318.htm") + ("slot-missing-values:specify" "iss319.htm") + ("slot-value-metaclasses:less-minimal" "iss320.htm") + ("special-form-p-misnomer:rename" "iss321.htm") + ("special-type-shadowing:clarify" "iss322.htm") + ("standard-input-initial-binding:defined-contracts" "iss323.htm") + ("standard-repertoire-gratuitous:rename" "iss324.htm") + ("step-environment:current" "iss325.htm") + ("step-minimal:permit-progn" "iss326.htm") + ("stream-access:add-types-accessors" "iss327.htm") + ("stream-capabilities:interactive-stream-p" "iss328.htm") + ("string-coercion:make-consistent" "iss329.htm") + ("string-output-stream-bashing:undefined" "iss330.htm") + ("structure-read-print-syntax:keywords" "iss331.htm") + ("subseq-out-of-bounds" "iss332.htm") + ("subseq-out-of-bounds:is-an-error" "iss333.htm") + ("subsetting-position:none" "iss334.htm") + ("subtypep-environment:add-arg" "iss335.htm") + ("subtypep-too-vague:clarify-more" "iss336.htm") + ("sxhash-definition:similar-for-sxhash" "iss337.htm") + ("symbol-macrolet-declare:allow" "iss338.htm") + ("symbol-macrolet-semantics:special-form" "iss339.htm") + ("symbol-macrolet-type-declaration:no" "iss340.htm") + ("symbol-macros-and-proclaimed-specials:signals-an-error" "iss341.htm") + ("symbol-print-escape-behavior:clarify" "iss342.htm") + ("syntactic-environment-access:retracted-mar91" "iss343.htm") + ("tagbody-tag-expansion:no" "iss344.htm") + ("tailp-nil:t" "iss345.htm") + ("test-not-if-not:flush-all" "iss346.htm") + ("the-ambiguity:for-declaration" "iss347.htm") + ("the-values:return-number-received" "iss348.htm") + ("time-zone-non-integer:allow" "iss349.htm") + ("type-declaration-abbreviation:allow-all" "iss350.htm") + ("type-of-and-predefined-classes:type-of-handles-floats" "iss351.htm") + ("type-of-and-predefined-classes:unify-and-extend" "iss352.htm") + ("type-of-underconstrained:add-constraints" "iss353.htm") + ("type-specifier-abbreviation:x3j13-jun90-guess" "iss354.htm") + ("undefined-variables-and-functions:compromise" "iss355.htm") + ("uninitialized-elements:consequences-undefined" "iss356.htm") + ("unread-char-after-peek-char:dont-allow" "iss357.htm") + ("unsolicited-messages:not-to-system-user-streams" "iss358.htm") + ("variable-list-asymmetry:symmetrize" "iss359.htm") + ("with-added-methods:delete" "iss360.htm") + ("with-compilation-unit:new-macro" "iss361.htm") + ("with-open-file-does-not-exist:stream-is-nil" "iss362.htm") + ("with-open-file-setq:explicitly-vague" "iss363.htm") + ("with-open-file-stream-extent:dynamic-extent" "iss364.htm") + ("with-output-to-string-append-style:vector-push-extend" "iss365.htm") + ("with-standard-io-syntax-readtable:x3j13-mar-91" "iss366.htm")))) + +(defun common-lisp-issuex (issue-name) + (let ((symbol + (intern (downcase issue-name) common-lisp-hyperspec-issuex-symbols))) + (concat common-lisp-hyperspec-root "Issues/" (symbol-value symbol)))) + +(provide 'hyperspec) + +;;; hyperspec.el ends here
Added: branches/trunk-reorg/thirdparty/slime/metering.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/metering.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/metering.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,1222 @@ +;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.; -*- +;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz mkant@GLINDA.OZ.CS.CMU.EDU + +;;; **************************************************************** +;;; Metering System ************************************************ +;;; **************************************************************** +;;; +;;; The Metering System is a portable Common Lisp code profiling tool. +;;; It gathers timing and consing statistics for specified functions +;;; while a program is running. +;;; +;;; The Metering System is a combination of +;;; o the Monitor package written by Chris McConnell +;;; o the Profile package written by Skef Wholey and Rob MacLachlan +;;; The two systems were merged and extended by Mark Kantrowitz. +;;; +;;; Address: Carnegie Mellon University +;;; School of Computer Science +;;; Pittsburgh, PA 15213 +;;; +;;; This code is in the public domain and is distributed without warranty +;;; of any kind. +;;; +;;; This copy is from SLIME, http://www.common-lisp.net/project/slime/ +;;; +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 26-JUN-90 mk Merged functionality of Monitor and Profile packages. +;;; 26-JUN-90 mk Now handles both inclusive and exclusive statistics +;;; with respect to nested calls. (Allows it to subtract +;;; total monitoring overhead for each function, not just +;;; the time spent monitoring the function itself.) +;;; 26-JUN-90 mk The table is now saved so that one may manipulate +;;; the data (sorting it, etc.) even after the original +;;; source of the data has been cleared. +;;; 25-SEP-90 mk Added get-cons functions for Lucid 3.0, MACL 1.3.2 +;;; required-arguments functions for Lucid 3.0, +;;; Franz Allegro CL, and MACL 1.3.2. +;;; 25-JAN-91 mk Now uses fdefinition if available. +;;; 25-JAN-91 mk Replaced (and :allegro (not :coral)) with :excl. +;;; Much better solution for the fact that both call +;;; themselves :allegro. +;;; 5-JUL-91 mk Fixed warning to occur only when file is loaded +;;; uncompiled. +;;; 5-JUL-91 mk When many unmonitored functions, print out number +;;; instead of whole list. +;;; 24-MAR-92 mk Updated for CLtL2 compatibility. space measuring +;;; doesn't work in MCL, but fixed so that timing +;;; statistics do. +;;; 26-MAR-92 mk Updated for Lispworks. Replaced :ccl with +;;; (and :ccl (not :lispworks)). +;;; 27-MAR-92 mk Added get-cons for Allegro-V4.0. +;;; 01-JAN-93 mk v2.0 Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1, +;;; Lucid 4.0, ibcl +;;; 25-JAN-94 mk v2.1 Patches for CLISP from Bruno Haible. +;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL. +;;; Purely to cut down on stale code (e.g. #+cltl2) in this +;;; version that is bundled with SLIME. +;;; +;;; + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; - Need get-cons for Allegro, AKCL. +;;; - Speed up monitoring code. Replace use of hash tables with an embedded +;;; offset in an array so that it will be faster than using gethash. +;;; (i.e., svref/closure reference is usually faster than gethash). +;;; - Beware of (get-internal-run-time) overflowing. Yikes! +;;; - Check robustness with respect to profiled functions. +;;; - Check logic of computing inclusive and exclusive time and consing. +;;; Especially wrt incf/setf comment below. Should be incf, so we +;;; sum recursive calls. +;;; - Add option to record caller statistics -- this would list who +;;; called which functions and how often. +;;; - switches to turn timing/CONSING statistics collection on/off. + + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; METERING has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (16d, Python Compiler 1.0 ) :new-compiler +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; Macintosh Common Lisp (2.0) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 11/19/90) :allegro-v3.1 +;;; ExCL (Franz Allegro CL 4.0.1 [Sun4] 2/8/91) :allegro-v4.0 +;;; ExCL (Franz Allegro CL 4.1 [SPARC R1] 8/28/92 14:06) :allegro-v4.1 +;;; ExCL (Franz ACL 5.0.1 [Linux/X86] 6/29/99 16:11) :allegro-v5.0.1 +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; Lucid Common Lisp (3.0) +;;; Lucid Common Lisp (4.0.1 HP-700 12-Aug-91) +;;; AKCL (1.86, June 30, 1987 or later) +;;; Ibuki Common Lisp (Version 2, release 01.027) +;;; CLISP (January 1994) +;;; +;;; METERING needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; KCL (June 3, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; This system runs in any valid Common Lisp. Four small +;;; implementation-dependent changes can be made to improve performance +;;; and prettiness. In the section labelled "Implementation Dependent +;;; Changes" below, you should tailor the functions REQUIRED-ARGUMENTS, +;;; GET-CONS, GET-TIME, and TIME-UNITS-PER-SECOND to your implementation +;;; for the best results. If GET-CONS is not specified for your +;;; implementation, no consing information will be reported. The other +;;; functions will default to working forms, albeit inefficient, in +;;; non-CMU implementations. If you tailor these functions for a particular +;;; version of Common Lisp, we'd appreciate receiving the code. +;;; + +;;; **************************************************************** +;;; Usage Notes **************************************************** +;;; **************************************************************** +;;; +;;; SUGGESTED USAGE: +;;; +;;; Start by monitoring big pieces of the program, then carefully choose +;;; which functions close to, but not in, the inner loop are to be +;;; monitored next. Don't monitor functions that are called by other +;;; monitored functions: you will only confuse yourself. +;;; +;;; If the per-call time reported is less than 1/10th of a second, then +;;; consider the clock resolution and profiling overhead before you believe +;;; the time. It may be that you will need to run your program many times +;;; in order to average out to a higher resolution. +;;; +;;; The easiest way to use this package is to load it and execute either +;;; (mon:with-monitoring (names*) () +;;; your-forms*) +;;; or +;;; (mon:monitor-form your-form) +;;; The former allows you to specify which functions will be monitored; the +;;; latter monitors all functions in the current package. Both automatically +;;; produce a table of statistics. Other variants can be constructed from +;;; the monitoring primitives, which are described below, along with a +;;; fuller description of these two macros. +;;; +;;; For best results, compile this file before using. +;;; +;;; +;;; CLOCK RESOLUTION: +;;; +;;; Unless you are very lucky, the length of your machine's clock "tick" is +;;; probably much longer than the time it takes a simple function to run. +;;; For example, on the IBM RT, the clock resolution is 1/50th of a second. +;;; This means that if a function is only called a few times, then only the +;;; first couple of decimal places are really meaningful. +;;; +;;; +;;; MONITORING OVERHEAD: +;;; +;;; The added monitoring code takes time to run every time that the monitored +;;; function is called, which can disrupt the attempt to collect timing +;;; information. In order to avoid serious inflation of the times for functions +;;; that take little time to run, an estimate of the overhead due to monitoring +;;; is subtracted from the times reported for each function. +;;; +;;; Although this correction works fairly well, it is not totally accurate, +;;; resulting in times that become increasingly meaningless for functions +;;; with short runtimes. For example, subtracting the estimated overhead +;;; may result in negative times for some functions. This is only a concern +;;; when the estimated profiling overhead is many times larger than +;;; reported total CPU time. +;;; +;;; If you monitor functions that are called by monitored functions, in +;;; :inclusive mode the monitoring overhead for the inner function is +;;; subtracted from the CPU time for the outer function. [We do this by +;;; counting for each function not only the number of calls to *this* +;;; function, but also the number of monitored calls while it was running.] +;;; In :exclusive mode this is not necessary, since we subtract the +;;; monitoring time of inner functions, overhead & all. +;;; +;;; Otherwise, the estimated monitoring overhead is not represented in the +;;; reported total CPU time. The sum of total CPU time and the estimated +;;; monitoring overhead should be close to the total CPU time for the +;;; entire monitoring run (as determined by TIME). +;;; +;;; A timing overhead factor is computed at load time. This will be incorrect +;;; if the monitoring code is run in a different environment than this file +;;; was loaded in. For example, saving a core image on a high performance +;;; machine and running it on a low performance one will result in the use +;;; of an erroneously small overhead factor. +;;; +;;; +;;; If your times vary widely, possible causes are: +;;; - Garbage collection. Try turning it off, then running your code. +;;; Be warned that monitoring code will probably cons when it does +;;; (get-internal-run-time). +;;; - Swapping. If you have enough memory, execute your form once +;;; before monitoring so that it will be swapped into memory. Otherwise, +;;; get a bigger machine! +;;; - Resolution of internal-time-units-per-second. If this value is +;;; too low, then the timings become wild. You can try executing more +;;; of whatever your test is, but that will only work if some of your +;;; paths do not match the timer resolution. +;;; internal-time-units-per-second is so coarse -- on a Symbolics it is +;;; 977, in MACL it is 60. +;;; +;;; + +;;; **************************************************************** +;;; Interface ****************************************************** +;;; **************************************************************** +;;; +;;; WITH-MONITORING (&rest functions) [Macro] +;;; (&optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time)) +;;; &body body +;;; The named functions will be set up for monitoring, the body forms executed, +;;; a table of results printed, and the functions unmonitored. The nested, +;;; threshold, and key arguments are passed to report-monitoring below. +;;; +;;; MONITOR-FORM form [Macro] +;;; &optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; All functions in the current package are set up for monitoring while +;;; the form is executed, and automatically unmonitored after a table of +;;; results has been printed. The nested, threshold, and key arguments +;;; are passed to report-monitoring below. +;;; +;;; *MONITORED-FUNCTIONS* [Variable] +;;; This holds a list of all functions that are currently being monitored. +;;; +;;; MONITOR &rest names [Macro] +;;; The named functions will be set up for monitoring by augmenting +;;; their function definitions with code that gathers statistical information +;;; about code performance. As with the TRACE macro, the function names are +;;; not evaluated. Calls the function MON::MONITORING-ENCAPSULATE on each +;;; function name. If no names are specified, returns a list of all +;;; monitored functions. +;;; +;;; If name is not a symbol, it is evaled to return the appropriate +;;; closure. This allows you to monitor closures stored anywhere like +;;; in a variable, array or structure. Most other monitoring packages +;;; can't handle this. +;;; +;;; MONITOR-ALL &optional (package *package*) [Function] +;;; Monitors all functions in the specified package, which defaults to +;;; the current package. +;;; +;;; UNMONITOR &rest names [Macro] +;;; Removes monitoring code from the named functions. If no names are +;;; specified, all currently monitored functions are unmonitored. +;;; +;;; RESET-MONITORING-INFO name [Function] +;;; Resets the monitoring statistics for the specified function. +;;; +;;; RESET-ALL-MONITORING [Function] +;;; Resets the monitoring statistics for all monitored functions. +;;; +;;; MONITORED name [Function] +;;; Predicate to test whether a function is monitored. +;;; +;;; REPORT-MONITORING &optional names [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; Creates a table of monitoring information for the specified list +;;; of names, and displays the table using display-monitoring-results. +;;; If names is :all or nil, uses all currently monitored functions. +;;; Takes the following arguments: +;;; - NESTED specifies whether nested calls of monitored functions +;;; are included in the times for monitored functions. +;;; o If :inclusive, the per-function information is for the entire +;;; duration of the monitored function, including any calls to +;;; other monitored functions. If functions A and B are monitored, +;;; and A calls B, then the accumulated time and consing for A will +;;; include the time and consing of B. Note: if a function calls +;;; itself recursively, the time spent in the inner call(s) may +;;; be counted several times. +;;; o If :exclusive, the information excludes time attributed to +;;; calls to other monitored functions. This is the default. +;;; - THRESHOLD specifies that only functions which have been executed +;;; more than threshold percent of the time will be reported. Defaults +;;; to 1%. If a threshold of 0 is specified, all functions are listed, +;;; even those with 0 or negative running times (see note on overhead). +;;; - KEY specifies that the table be sorted by one of the following +;;; sort keys: +;;; :function alphabetically by function name +;;; :percent-time by percent of total execution time +;;; :percent-cons by percent of total consing +;;; :calls by number of times the function was called +;;; :time-per-call by average execution time per function +;;; :cons-per-call by average consing per function +;;; :time same as :percent-time +;;; :cons same as :percent-cons +;;; +;;; REPORT &key (names :all) [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (sort-key :percent-time) +;;; (ignore-no-calls nil) +;;; +;;; Same as REPORT-MONITORING but we use a nicer keyword interface. +;;; +;;; DISPLAY-MONITORING-RESULTS &optional (threshold 0.01) [Function] +;;; (key :percent-time) +;;; Prints a table showing for each named function: +;;; - the total CPU time used in that function for all calls +;;; - the total number of bytes consed in that function for all calls +;;; - the total number of calls +;;; - the average amount of CPU time per call +;;; - the average amount of consing per call +;;; - the percent of total execution time spent executing that function +;;; - the percent of total consing spent consing in that function +;;; Summary totals of the CPU time, consing, and calls columns are printed. +;;; An estimate of the monitoring overhead is also printed. May be run +;;; even after unmonitoring all the functions, to play with the data. +;;; +;;; SAMPLE TABLE: +#| + Cons + % % Per Total Total +Function Time Cons Calls Sec/Call Call Time Cons +---------------------------------------------------------------------- +FIND-ROLE: 0.58 0.00 136 0.003521 0 0.478863 0 +GROUP-ROLE: 0.35 0.00 365 0.000802 0 0.292760 0 +GROUP-PROJECTOR: 0.05 0.00 102 0.000408 0 0.041648 0 +FEATURE-P: 0.02 0.00 570 0.000028 0 0.015680 0 +---------------------------------------------------------------------- +TOTAL: 1173 0.828950 0 +Estimated total monitoring overhead: 0.88 seconds +|# + +;;; **************************************************************** +;;; METERING ******************************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Warn people using the wrong Lisp +;;; ******************************** + +#-(or clisp openmcl) +(warn "metering.lisp does not support your Lisp implementation!") + +;;; ******************************** +;;; Packages *********************** +;;; ******************************** + +;;; For CLtL2 compatible lisps + +(defpackage "MONITOR" (:nicknames "MON") (:use "COMMON-LISP") + (:export "*MONITORED-FUNCTIONS*" + "MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM" + "WITH-MONITORING" + "RESET-MONITORING-INFO" "RESET-ALL-MONITORING" + "MONITORED" + "REPORT-MONITORING" + "DISPLAY-MONITORING-RESULTS" + "MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE" + "REPORT")) +(in-package "MONITOR") + +;;; Warn user if they're loading the source instead of compiling it first. +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + +;;; ******************************** +;;; Version ************************ +;;; ******************************** + +(defparameter *metering-version* "v2.1 25-JAN-94" + "Current version number/date for Metering.") + + +;;; **************************************************************** +;;; Implementation Dependent Definitions *************************** +;;; **************************************************************** + +;;; ******************************** +;;; Timing Functions *************** +;;; ******************************** +;;; The get-time function is called to find the total number of ticks since +;;; the beginning of time. time-units-per-second allows us to convert units +;;; to seconds. + +#-(or clisp openmcl) +(eval-when (compile eval) + (warn + "You may want to supply implementation-specific get-time functions.")) + +(defconstant time-units-per-second internal-time-units-per-second) + +(defmacro get-time () + `(the time-type (get-internal-run-time))) + +;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of +;;; milliseconds spent during GC. We could subtract this from +;;; the value returned by get-internal-run-time to eliminate +;;; the effect of GC on the timing values, but we prefer to let +;;; the user run without GC on. If the application is so big that +;;; it requires GC to complete, then the GC times are part of the +;;; cost of doing business, and will average out in the long run. +;;; If it seems really important to a user that GC times not be +;;; counted, then uncomment the following three lines and read-time +;;; conditionalize the definition of get-time above with #-:openmcl. +;#+openmcl +;(defmacro get-time () +; `(the time-type (- (get-internal-run-time) (ccl:gctime)))) + +;;; ******************************** +;;; Consing Functions ************** +;;; ******************************** +;;; The get-cons macro is called to find the total number of bytes +;;; consed since the beginning of time. + +#+clisp +(defun get-cons () + (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount) + (sys::%%time) + (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount)) + (dpb space1 (byte 24 24) space2))) + +;;; Macintosh Common Lisp 2.0 +;;; Note that this includes bytes that were allocated during GC. +;;; We could subtract this out by advising GC like we did under +;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't +;;; run without GC, then the bytes consed during GC are a cost of +;;; running their program. Metering the code a few times will +;;; avoid the consing values being too lopsided. If a user really really +;;; wants to subtract out the consing during GC, replace the following +;;; two lines with the commented out code. +#+openmcl +(defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated))) +;; #+openmcl +;; (progn +;; (in-package :ccl) +;; (defvar *bytes-consed-chkpt* 0) +;; (defun reset-consing () (setq *bytes-consed-chkpt* 0)) +;; (let ((old-gc (symbol-function 'gc)) +;; (ccl:*warn-if-redefine-kernel* nil)) +;; (setf (symbol-function 'gc) +;; #'(lambda () +;; (let ((old-consing (total-bytes-consed))) +;; (prog1 +;; (funcall old-gc) +;; (incf *bytes-consed-chkpt* +;; (- old-consing (total-bytes-consed)))))))) +;; (defun total-bytes-consed () +;; "Returns number of conses (8 bytes each)" +;; (ccl::total-bytes-allocated)) +;; (in-package "MONITOR") +;; (defun get-cons () +;; (the consing-type (+ (ccl::total-bytes-consed) ccl::*bytes-consed-chkpt*)))) + + +#-(or clisp openmcl) +(progn + (eval-when (compile eval) + (warn "No consing will be reported unless a get-cons function is ~ + defined.")) + + (defmacro get-cons () '(the consing-type 0))) + +;; actually, neither `get-cons' nor `get-time' are used as is, +;; but only in the following macro `with-time/cons' +#-:clisp +(defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((start-cons (gensym "START-CONS-")) + (start-time (gensym "START-TIME-"))) + `(let ((,start-time (get-time)) (,start-cons (get-cons))) + (declare (type time-type ,start-time) + (type consing-type ,start-cons)) + (multiple-value-prog1 ,form + (let ((,delta-time (- (get-time) ,start-time)) + (,delta-cons (- (get-cons) ,start-cons))) + ,@post-process))))) + +#+clisp +(progn + (defmacro delta4 (nv1 nv2 ov1 ov2 by) + `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2)) + + (let ((del (find-symbol "DELTA4" "SYS"))) + (when del (setf (fdefinition 'delta4) (fdefinition del)))) + + (if (< internal-time-units-per-second 1000000) + ;; TIME_1: AMIGA, OS/2, UNIX_TIMES + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16)) + ;; TIME_2: other UNIX, WIN32 + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second) + (- ,new-time2 ,old-time2)))) + + (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2) + `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24)) + + ;; avoid consing: when the application conses a lot, + ;; get-cons may return a bignum, so we really should not use it. + (defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-")) + (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-")) + (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-")) + (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-")) + (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym))) + `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2 + ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (multiple-value-prog1 ,form + (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2 + ,gc1 ,gc2 ,end-cons1 ,end-cons2) (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (let ((,delta-time (delta4-time ,end-time1 ,end-time2 + ,beg-time1 ,beg-time2)) + (,delta-cons (delta4-cons ,end-cons1 ,end-cons2 + ,beg-cons1 ,beg-cons2))) + ,@post-process))))))) + +;;; ******************************** +;;; Required Arguments ************* +;;; ******************************** +;;; +;;; Required (Fixed) vs Optional Args +;;; +;;; To avoid unnecessary consing in the "encapsulation" code, we find out the +;;; number of required arguments, and use &rest to capture only non-required +;;; arguments. The function Required-Arguments returns two values: the first +;;; is the number of required arguments, and the second is T iff there are any +;;; non-required arguments (e.g. &optional, &rest, &key). + +;;; Lucid, Allegro, and Macintosh Common Lisp +#+openmcl +(defun required-arguments (name) + (let* ((function (symbol-function name)) + (args (ccl:arglist function)) + (pos (position-if #'(lambda (x) + (and (symbolp x) + (let ((name (symbol-name x))) + (and (>= (length name) 1) + (char= (schar name 0) + #&))))) + args))) + (if pos + (values pos t) + (values (length args) nil)))) + +#+clisp +(defun required-arguments (name) + (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p) + (sys::function-signature name t) + (if name ; no error + (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p)) + (values 0 t)))) + +#-(or clisp openmcl) +(progn + (eval-when (compile eval) + (warn + "You may want to add an implementation-specific Required-Arguments function.")) + (eval-when (load eval) + (defun required-arguments (name) + (declare (ignore name)) + (values 0 t)))) + +#| +;;;Examples +(defun square (x) (* x x)) +(defun square2 (x &optional y) (* x x y)) +(defun test (x y &optional (z 3)) 3) +(defun test2 (x y &optional (z 3) &rest fred) 3) + +(required-arguments 'square) => 1 nil +(required-arguments 'square2) => 1 t +(required-arguments 'test) => 2 t +(required-arguments 'test2) => 2 t +|# + + +;;; **************************************************************** +;;; Main METERING Code ********************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Global Variables *************** +;;; ******************************** +(defvar *MONITOR-TIME-OVERHEAD* nil + "The amount of time an empty monitored function costs.") +(defvar *MONITOR-CONS-OVERHEAD* nil + "The amount of cons an empty monitored function costs.") + +(defvar *TOTAL-TIME* 0 + "Total amount of time monitored so far.") +(defvar *TOTAL-CONS* 0 + "Total amount of consing monitored so far.") +(defvar *TOTAL-CALLS* 0 + "Total number of calls monitored so far.") +(proclaim '(type time-type *total-time*)) +(proclaim '(type consing-type *total-cons*)) +(proclaim '(fixnum *total-calls*)) + +;;; ******************************** +;;; Accessor Functions ************* +;;; ******************************** +;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables +;;; containing closures. +(defmacro PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + ;; Note that (fboundp 'fdefinition) returns T even if fdefinition + ;; is a macro, which is what we want. + (if (fboundp 'fdefinition) + `(if (fboundp ,function-place) + (fdefinition ,function-place) + (eval ,function-place)) + `(if (symbolp ,function-place) + (symbol-function ,function-place) + (eval ,function-place)))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + (if (fboundp 'fdefinition) + ;; If we're conforming to CLtL2, use fdefinition here. + `(if (fboundp ,function-place) + (setf (fdefinition ,function-place) ,function) + (eval '(setf ,function-place ',function))) + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function))))) + +#| +;;; before using fdefinition +(defun PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + (if (symbolp function-place) + (symbol-function function-place) + (eval function-place))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function)))) +|# + +(defun PLACE-FBOUNDP (function-place) + "Test to see if FUNCTION-PLACE is a function." + ;; probably should be + #|(or (and (symbolp function-place)(fboundp function-place)) + (functionp (place-function function-place)))|# + (if (symbolp function-place) + (fboundp function-place) + (functionp (place-function function-place)))) + +(defun PLACE-MACROP (function-place) + "Test to see if FUNCTION-PLACE is a macro." + (when (symbolp function-place) + (macro-function function-place))) + +;;; ******************************** +;;; Measurement Tables ************* +;;; ******************************** +(defvar *monitored-functions* nil + "List of monitored symbols.") + +;;; We associate a METERING-FUNCTIONS structure with each monitored function +;;; name or other closure. This holds the functions that we call to manipulate +;;; the closure which implements the encapsulation. +;;; +(defstruct metering-functions + (name nil) + (old-definition nil :type function) + (new-definition nil :type function) + (read-metering nil :type function) + (reset-metering nil :type function)) + +;;; In general using hash tables in time-critical programs is a bad idea, +;;; because when one has to grow the table and rehash everything, the +;;; timing becomes grossly inaccurate. In this case it is not an issue +;;; because all inserting of entries in the hash table occurs before the +;;; timing commences. The only circumstance in which this could be a +;;; problem is if the lisp rehashes on the next reference to the table, +;;; instead of when the entry which forces a rehash was inserted. +;;; +;;; Note that a similar kind of problem can occur with GC, which is why +;;; one should turn off GC when monitoring code. +;;; +(defvar *monitor* (make-hash-table :test #'equal) + "Hash table in which METERING-FUNCTIONS structures are stored.") +(defun get-monitor-info (name) + (gethash name *monitor*)) +(defsetf get-monitor-info (name) (info) + `(setf (gethash ,name *monitor*) ,info)) + +(defun MONITORED (function-place) + "Test to see if a FUNCTION-PLACE is monitored." + (and (place-fboundp function-place) ; this line necessary? + (get-monitor-info function-place))) + +(defun reset-monitoring-info (name) + "Reset the monitoring info for the specified function." + (let ((finfo (get-monitor-info name))) + (when finfo + (funcall (metering-functions-reset-metering finfo))))) +(defun reset-all-monitoring () + "Reset monitoring info for all functions." + (setq *total-time* 0 + *total-cons* 0 + *total-calls* 0) + (dolist (symbol *monitored-functions*) + (when (monitored symbol) + (reset-monitoring-info symbol)))) + +(defun monitor-info-values (name &optional (nested :exclusive) warn) + "Returns monitoring information values for the named function, +adjusted for overhead." + (let ((finfo (get-monitor-info name))) + (if finfo + (multiple-value-bind (inclusive-time inclusive-cons + exclusive-time exclusive-cons + calls nested-calls) + (funcall (metering-functions-read-metering finfo)) + (unless (or (null warn) + (eq (place-function name) + (metering-functions-new-definition finfo))) + (warn "Funtion ~S has been redefined, so times may be inaccurate.~@ + MONITOR it again to record calls to the new definition." + name)) + (case nested + (:exclusive (values calls + nested-calls + (- exclusive-time + (* calls *monitor-time-overhead*)) + (- exclusive-cons + (* calls *monitor-cons-overhead*)))) + ;; In :inclusive mode, subtract overhead for all the + ;; called functions as well. Nested-calls includes the + ;; calls of the function as well. [Necessary 'cause of + ;; functions which call themselves recursively.] + (:inclusive (values calls + nested-calls + (- inclusive-time + (* nested-calls ;(+ calls) + *monitor-time-overhead*)) + (- inclusive-cons + (* nested-calls ;(+ calls) + *monitor-cons-overhead*)))))) + (values 0 0 0 0)))) + +;;; ******************************** +;;; Encapsulate ******************** +;;; ******************************** +(eval-when (compile load eval) +;; Returns a lambda expression for a function that, when called with the +;; function name, will set up that function for metering. +;; +;; A function is monitored by replacing its definition with a closure +;; created by the following function. The closure records the monitoring +;; data, and updates the data with each call of the function. +;; +;; Other closures are used to read and reset the data. +(defun make-monitoring-encapsulation (min-args optionals-p) + (let (required-args) + (dotimes (i min-args) (push (gensym) required-args)) + `(lambda (name) + (let ((inclusive-time 0) + (inclusive-cons 0) + (exclusive-time 0) + (exclusive-cons 0) + (calls 0) + (nested-calls 0) + (old-definition (place-function name))) + (declare (type time-type inclusive-time) + (type time-type exclusive-time) + (type consing-type inclusive-cons) + (type consing-type exclusive-cons) + (fixnum calls) + (fixnum nested-calls)) + (pushnew name *monitored-functions*) + + (setf (place-function name) + #'(lambda (,@required-args + ,@(when optionals-p + `(&rest optional-args))) + (let ((prev-total-time *total-time*) + (prev-total-cons *total-cons*) + (prev-total-calls *total-calls*) + ;; (old-time inclusive-time) + ;; (old-cons inclusive-cons) + ;; (old-nested-calls nested-calls) + ) + (declare (type time-type prev-total-time) + (type consing-type prev-total-cons) + (fixnum prev-total-calls)) + (with-time/cons (delta-time delta-cons) + ;; form + ,(if optionals-p + `(apply old-definition + ,@required-args optional-args) + `(funcall old-definition ,@required-args)) + ;; post-processing: + ;; Calls + (incf calls) + (incf *total-calls*) + ;; nested-calls includes this call + (incf nested-calls (the fixnum + (- *total-calls* + prev-total-calls))) + ;; (setf nested-calls (+ old-nested-calls + ;; (- *total-calls* + ;; prev-total-calls))) + ;; Time + ;; Problem with inclusive time is that it + ;; currently doesn't add values from recursive + ;; calls to the same function. Change the + ;; setf to an incf to fix this? + (incf inclusive-time (the time-type delta-time)) + ;; (setf inclusive-time (+ delta-time old-time)) + (incf exclusive-time (the time-type + (+ delta-time + (- prev-total-time + *total-time*)))) + (setf *total-time* (the time-type + (+ delta-time + prev-total-time))) + ;; Consing + (incf inclusive-cons (the consing-type delta-cons)) + ;; (setf inclusive-cons (+ delta-cons old-cons)) + (incf exclusive-cons (the consing-type + (+ delta-cons + (- prev-total-cons + *total-cons*)))) + (setf *total-cons* + (the consing-type + (+ delta-cons prev-total-cons))))))) + (setf (get-monitor-info name) + (make-metering-functions + :name name + :old-definition old-definition + :new-definition (place-function name) + :read-metering #'(lambda () + (values inclusive-time + inclusive-cons + exclusive-time + exclusive-cons + calls + nested-calls)) + :reset-metering #'(lambda () + (setq inclusive-time 0 + inclusive-cons 0 + exclusive-time 0 + exclusive-cons 0 + calls 0 + nested-calls 0) + t))))))) +);; End of EVAL-WHEN + +;;; For efficiency reasons, we precompute the encapsulation functions +;;; for a variety of combinations of argument structures +;;; (min-args . optional-p). These are stored in the following hash table +;;; along with any new ones we encounter. Since we're now precomputing +;;; closure functions for common argument signatures, this eliminates +;;; the former need to call COMPILE for each monitored function. +(eval-when (compile eval) + (defconstant precomputed-encapsulations 8)) + +(defvar *existing-encapsulations* (make-hash-table :test #'equal)) +(defun find-encapsulation (min-args optionals-p) + (or (gethash (cons min-args optionals-p) *existing-encapsulations*) + (setf (gethash (cons min-args optionals-p) *existing-encapsulations*) + (compile nil + (make-monitoring-encapsulation min-args optionals-p))))) + +(macrolet ((frob () + (let ((res ())) + (dotimes (i precomputed-encapsulations) + (push `(setf (gethash '(,i . nil) *existing-encapsulations*) + #',(make-monitoring-encapsulation i nil)) + res) + (push `(setf (gethash '(,i . t) *existing-encapsulations*) + #',(make-monitoring-encapsulation i t)) + res)) + `(progn ,@res)))) + (frob)) + +(defun monitoring-encapsulate (name &optional warn) + "Monitor the function Name. If already monitored, unmonitor first." + ;; Saves the current definition of name and inserts a new function which + ;; returns the result of evaluating body. + (cond ((not (place-fboundp name)) ; not a function + (when warn + (warn "Ignoring undefined function ~S." name))) + ((place-macrop name) ; a macro + (when warn + (warn "Ignoring macro ~S." name))) + (t ; tis a function + (when (get-monitor-info name) ; monitored + (when warn + (warn "~S already monitored, so unmonitoring it first." name)) + (monitoring-unencapsulate name)) + (multiple-value-bind (min-args optionals-p) + (required-arguments name) + (funcall (find-encapsulation min-args optionals-p) name))))) + +(defun monitoring-unencapsulate (name &optional warn) + "Removes monitoring encapsulation code from around Name." + (let ((finfo (get-monitor-info name))) + (when finfo ; monitored + (remprop name 'metering-functions) + (setq *monitored-functions* + (remove name *monitored-functions* :test #'equal)) + (if (eq (place-function name) + (metering-functions-new-definition finfo)) + (setf (place-function name) + (metering-functions-old-definition finfo)) + (when warn + (warn "Preserving current definition of redefined function ~S." + name)))))) + +;;; ******************************** +;;; Main Monitoring Functions ****** +;;; ******************************** +(defmacro MONITOR (&rest names) + "Monitor the named functions. As in TRACE, the names are not evaluated. + If a function is already monitored, then unmonitor and remonitor (useful + to notice function redefinition). If a name is undefined, give a warning + and ignore it. See also unmonitor, report-monitoring, + display-monitoring-results and reset-time." + `(progn + ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names) + *monitored-functions*)) + +(defmacro UNMONITOR (&rest names) + "Remove the monitoring on the named functions. + Names defaults to the list of all currently monitored functions." + `(dolist (name ,(if names `',names '*monitored-functions*) (values)) + (monitoring-unencapsulate name))) + +(defun MONITOR-ALL (&optional (package *package*)) + "Monitor all functions in the specified package." + (let ((package (if (packagep package) + package + (find-package package)))) + (do-symbols (symbol package) + (when (eq (symbol-package symbol) package) + (monitoring-encapsulate symbol))))) + +(defmacro MONITOR-FORM (form + &optional (nested :exclusive) (threshold 0.01) + (key :percent-time)) + "Monitor the execution of all functions in the current package +during the execution of FORM. All functions that are executed above +THRESHOLD % will be reported." + `(unwind-protect + (progn + (monitor-all) + (reset-all-monitoring) + (prog1 + (time ,form) + (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls))) + (unmonitor))) + +(defmacro WITH-MONITORING ((&rest functions) + (&optional (nested :exclusive) + (threshold 0.01) + (key :percent-time)) + &body body) + "Monitor the specified functions during the execution of the body." + `(unwind-protect + (progn + (dolist (fun ',functions) + (monitoring-encapsulate fun)) + (reset-all-monitoring) + ,@body + (report-monitoring :all ,nested ,threshold ,key)) + (unmonitor))) + +;;; ******************************** +;;; Overhead Calculations ********** +;;; ******************************** +(defconstant overhead-iterations 5000 + "Number of iterations over which the timing overhead is averaged.") + +;;; Perhaps this should return something to frustrate clever compilers. +(defun STUB-FUNCTION (x) + (declare (ignore x)) + nil) +(proclaim '(notinline stub-function)) + +(defun SET-MONITOR-OVERHEAD () + "Determines the average overhead of monitoring by monitoring the execution +of an empty function many times." + (setq *monitor-time-overhead* 0 + *monitor-cons-overhead* 0) + (stub-function nil) + (monitor stub-function) + (reset-all-monitoring) + (let ((overhead-function (symbol-function 'stub-function))) + (dotimes (x overhead-iterations) + (funcall overhead-function overhead-function))) +; (dotimes (x overhead-iterations) +; (stub-function nil)) + (let ((fiter (float overhead-iterations))) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values 'stub-function) + (declare (ignore calls nested-calls)) + (setq *monitor-time-overhead* (/ time fiter) + *monitor-cons-overhead* (/ cons fiter)))) + (unmonitor stub-function)) +(set-monitor-overhead) + +;;; ******************************** +;;; Report Data ******************** +;;; ******************************** +(defvar *monitor-results* nil + "A table of monitoring statistics is stored here.") +(defvar *no-calls* nil + "A list of monitored functions which weren't called.") +(defvar *estimated-total-overhead* 0) +;; (proclaim '(type time-type *estimated-total-overhead*)) + +(defstruct (monitoring-info + (:conc-name m-info-) + (:constructor make-monitoring-info + (name calls time cons + percent-time percent-cons + time-per-call cons-per-call))) + name + calls + time + cons + percent-time + percent-cons + time-per-call + cons-per-call) + +(defun REPORT (&key (names :all) + (nested :exclusive) + (threshold 0.01) + (sort-key :percent-time) + (ignore-no-calls nil)) + "Same as REPORT-MONITORING but with a nicer keyword interface" + (declare (type (member :function :percent-time :time :percent-cons + :cons :calls :time-per-call :cons-per-call) + sort-key) + (type (member :inclusive :exclusive) nested)) + (report-monitoring names nested threshold sort-key ignore-no-calls)) + +(defun REPORT-MONITORING (&optional names + (nested :exclusive) + (threshold 0.01) + (key :percent-time) + ignore-no-calls) + "Report the current monitoring state. +The percentage of the total time spent executing unmonitored code +in each function (:exclusive mode), or total time (:inclusive mode) +will be printed together with the number of calls and +the unmonitored time per call. Functions that have been executed +below THRESHOLD % of the time will not be reported. To report on all +functions set NAMES to be either NIL or :ALL." + (when (or (null names) (eq names :all)) (setq names *monitored-functions*)) + + (let ((total-time 0) + (total-cons 0) + (total-calls 0)) + ;; Compute overall time and consing. + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested :warn) + (declare (ignore nested-calls)) + (incf total-calls calls) + (incf total-time time) + (incf total-cons cons))) + ;; Total overhead. + (setq *estimated-total-overhead* + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second)) + ;; Assemble data for only the specified names (all monitored functions) + (if (zerop total-time) + (format *trace-output* "Not enough execution time to monitor.") + (progn + (setq *monitor-results* nil *no-calls* nil) + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested) + (declare (ignore nested-calls)) + (when (minusp time) (setq time 0.0)) + (when (minusp cons) (setq cons 0.0)) + (if (zerop calls) + (push (if (symbolp name) + (symbol-name name) + (format nil "~S" name)) + *no-calls*) + (push (make-monitoring-info + (format nil "~S" name) ; name + calls ; calls + (/ time (float time-units-per-second)) ; time in secs + (round cons) ; consing + (/ time (float total-time)) ; percent-time + (if (zerop total-cons) 0 + (/ cons (float total-cons))) ; percent-cons + (/ (/ time (float calls)) ; time-per-call + time-units-per-second) ; sec/call + (round (/ cons (float calls)))) ; cons-per-call + *monitor-results*)))) + (display-monitoring-results threshold key ignore-no-calls))))) + +(defun display-monitoring-results (&optional (threshold 0.01) (key :percent-time) + (ignore-no-calls t)) + (let ((max-length 8) ; Function header size + (max-cons-length 8) + (total-time 0.0) + (total-consed 0) + (total-calls 0) + (total-percent-time 0) + (total-percent-cons 0)) + (sort-results key) + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (setq max-length + (max max-length + (length (m-info-name result)))) + (setq max-cons-length + (max max-cons-length + (m-info-cons-per-call result))))) + (incf max-length 2) + (setf max-cons-length (+ 2 (ceiling (log max-cons-length 10)))) + (format *trace-output* + "~%~%~ + ~VT ~VA~ + ~% ~VT % % ~VA Total Total~ + ~%Function~VT Time Cons Calls Sec/Call ~VA Time Cons~ + ~%~V,,,'-A" + max-length + max-cons-length "Cons" + max-length + max-cons-length "Per" + max-length + max-cons-length "Call" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-") + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (format *trace-output* + "~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D" + (m-info-name result) + max-length + (* 100 (m-info-percent-time result)) + (* 100 (m-info-percent-cons result)) + (m-info-calls result) + (m-info-time-per-call result) + max-cons-length + (m-info-cons-per-call result) + (m-info-time result) + (m-info-cons result)) + (incf total-time (m-info-time result)) + (incf total-consed (m-info-cons result)) + (incf total-calls (m-info-calls result)) + (incf total-percent-time (m-info-percent-time result)) + (incf total-percent-cons (m-info-percent-cons result)))) + (format *trace-output* + "~%~V,,,'-A~ + ~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~ + ~%Estimated monitoring overhead: ~5,2F seconds~ + ~%Estimated total monitoring overhead: ~5,2F seconds" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-" + max-length + (* 100 total-percent-time) + (* 100 total-percent-cons) + total-calls + max-cons-length " " + total-time total-consed + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second) + *estimated-total-overhead*) + (when (and (not ignore-no-calls) *no-calls*) + (setq *no-calls* (sort *no-calls* #'string<)) + (let ((num-no-calls (length *no-calls*))) + (if (> num-no-calls 20) + (format *trace-output* + "~%~@(~r~) monitored functions were not called. ~ + ~%See the variable mon::*no-calls* for a list." + num-no-calls) + (format *trace-output* + "~%The following monitored functions were not called:~ + ~%~{~<~%~:; ~A~>~}~%" + *no-calls*)))) + (values))) + +(defun sort-results (&optional (key :percent-time)) + (setq *monitor-results* + (case key + (:function (sort *monitor-results* #'string> + :key #'m-info-name)) + ((:percent-time :time) (sort *monitor-results* #'> + :key #'m-info-time)) + ((:percent-cons :cons) (sort *monitor-results* #'> + :key #'m-info-cons)) + (:calls (sort *monitor-results* #'> + :key #'m-info-calls)) + (:time-per-call (sort *monitor-results* #'> + :key #'m-info-time-per-call)) + (:cons-per-call (sort *monitor-results* #'> + :key #'m-info-cons-per-call))))) + +;;; *END OF FILE* + +
Added: branches/trunk-reorg/thirdparty/slime/mkdist.sh =================================================================== --- branches/trunk-reorg/thirdparty/slime/mkdist.sh 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/mkdist.sh 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,17 @@ +#!/bin/sh + +# This code has been placed in the Public Domain. All warranties +# are disclaimed. + +version="1.2" +dist="slime-$version" + +if [ -d $dist ]; then rm -rf $dist; fi + +mkdir $dist +cp NEWS README HACKING PROBLEMS ChangeLog *.el *.lisp $dist/ + +mkdir $dist/doc +cp doc/Makefile doc/slime.texi doc/texinfo-tabulate.awk $dist/doc + +tar czf $dist.tar.gz $dist
Property changes on: branches/trunk-reorg/thirdparty/slime/mkdist.sh ___________________________________________________________________ Name: svn:executable + *
Added: branches/trunk-reorg/thirdparty/slime/nregex.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/nregex.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/nregex.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,523 @@ +;;; +;;; This code was written by: +;;; +;;; Lawrence E. Freil lef@freil.com +;;; National Science Center Foundation +;;; Augusta, Georgia 30909 +;;; +;;; This program was released into the public domain on 2005-08-31. +;;; (See the slime-devel mailing list archive for details.) +;;; +;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression +;;; parser. +;;; +;;; This regular expression parser operates by taking a +;;; regular expression and breaking it down into a list +;;; consisting of lisp expressions and flags. The list +;;; of lisp expressions is then taken in turned into a +;;; lambda expression that can be later applied to a +;;; string argument for parsing. +;;;; +;;;; Modifications made 6 March 2001 By Chris Double (chris@double.co.nz) +;;;; to get working with Corman Lisp 1.42, add package statement and export +;;;; relevant functions. +;;;; + +(in-package :cl-user) + +;; Renamed to slime-nregex avoid name clashes with other versions of +;; this file. -- he + +;;;; CND - 6/3/2001 +(defpackage slime-nregex + (:use #:common-lisp) + (:export + #:regex + #:regex-compile + )) + +;;;; CND - 6/3/2001 +(in-package :slime-nregex) + +;;; +;;; First we create a copy of macros to help debug the beast +(eval-when (:compile-toplevel :load-toplevel :execute) +(defvar *regex-debug* nil) ; Set to nil for no debugging code +) + +(defmacro info (message &rest args) + (if *regex-debug* + `(format *standard-output* ,message ,@args))) + +;;; +;;; Declare the global variables for storing the paren index list. +;;; +(defvar *regex-groups* (make-array 10)) +(defvar *regex-groupings* 0) + +;;; +;;; Declare a simple interface for testing. You probably wouldn't want +;;; to use this interface unless you were just calling this once. +;;; +(defun regex (expression string) + "Usage: (regex <expression> <string) + This function will call regex-compile on the expression and then apply + the string to the returned lambda list." + (let ((findit (cond ((stringp expression) + (regex-compile expression)) + ((listp expression) + expression))) + (result nil)) + (if (not (funcall (if (functionp findit) + findit + (eval `(function ,findit))) string)) + (return-from regex nil)) + (if (= *regex-groupings* 0) + (return-from regex t)) + (dotimes (i *regex-groupings*) + (push (funcall 'subseq + string + (car (aref *regex-groups* i)) + (cadr (aref *regex-groups* i))) + result)) + (reverse result))) + +;;; +;;; Declare some simple macros to make the code more readable. +;;; +(defvar *regex-special-chars* "?*+.()[]\${}") + +(defmacro add-exp (list) + "Add an item to the end of expression" + `(setf expression (append expression ,list))) + +;;; +;;; Define a function that will take a quoted character and return +;;; what the real character should be plus how much of the source +;;; string was used. If the result is a set of characters, return an +;;; array of bits indicating which characters should be set. If the +;;; expression is one of the sub-group matches return a +;;; list-expression that will provide the match. +;;; +(defun regex-quoted (char-string &optional (invert nil)) + "Usage: (regex-quoted <char-string> &optional invert) + Returns either the quoted character or a simple bit vector of bits set for + the matching values" + (let ((first (char char-string 0)) + (result (char char-string 0)) + (used-length 1)) + (cond ((eql first #\n) + (setf result #\NewLine)) + ((eql first #\c) + (setf result #\Return)) + ((eql first #\t) + (setf result #\Tab)) + ((eql first #\d) + (setf result #*0000000000000000000000000000000000000000000000001111111111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\D) + (setf result #*1111111111111111111111111111111111111111111111110000000000111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\w) + (setf result #*0000000000000000000000000000000000000000000000001111111111000000011111111111111111111111111000010111111111111111111111111110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\W) + (setf result #*1111111111111111111111111111111111111111111111110000000000111111100000000000000000000000000111101000000000000000000000000001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\b) + (setf result #*0000000001000000000000000000000011000000000010100000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\B) + (setf result #*1111111110111111111111111111111100111111111101011111111111011111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((eql first #\s) + (setf result #*0000000001100000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) + ((eql first #\S) + (setf result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) + ((and (>= (char-code first) (char-code #\0)) + (<= (char-code first) (char-code #\9))) + (if (and (> (length char-string) 2) + (and (>= (char-code (char char-string 1)) (char-code #\0)) + (<= (char-code (char char-string 1)) (char-code #\9)) + (>= (char-code (char char-string 2)) (char-code #\0)) + (<= (char-code (char char-string 2)) (char-code #\9)))) + ;; + ;; It is a single character specified in octal + ;; + (progn + (setf result (do ((x 0 (1+ x)) + (return 0)) + ((= x 2) return) + (setf return (+ (* return 8) + (- (char-code (char char-string x)) + (char-code #\0)))))) + (setf used-length 3)) + ;; + ;; We have a group number replacement. + ;; + (let ((group (- (char-code first) (char-code #\0)))) + (setf result `((let ((nstring (subseq string (car (aref *regex-groups* ,group)) + (cadr (aref *regex-groups* ,group))))) + (if (< length (+ index (length nstring))) + (return-from compare nil)) + (if (not (string= string nstring + :start1 index + :end1 (+ index (length nstring)))) + (return-from compare nil) + (incf index (length nstring))))))))) + (t + (setf result first))) + (if (and (vectorp result) invert) + (bit-xor result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 t)) + (values result used-length))) + +;;; +;;; Now for the main regex compiler routine. +;;; +(defun regex-compile (source &key (anchored nil)) + "Usage: (regex-compile <expression> [ :anchored (t/nil) ]) + This function take a regular expression (supplied as source) and + compiles this into a lambda list that a string argument can then + be applied to. It is also possible to compile this lambda list + for better performance or to save it as a named function for later + use" + (info "Now entering regex-compile with "~A"~%" source) + ;; + ;; This routine works in two parts. + ;; The first pass take the regular expression and produces a list of + ;; operators and lisp expressions for the entire regular expression. + ;; The second pass takes this list and produces the lambda expression. + (let ((expression '()) ; holder for expressions + (group 1) ; Current group index + (group-stack nil) ; Stack of current group endings + (result nil) ; holder for built expression. + (fast-first nil)) ; holder for quick unanchored scan + ;; + ;; If the expression was an empty string then it alway + ;; matches (so lets leave early) + ;; + (if (= (length source) 0) + (return-from regex-compile + '(lambda (&rest args) + (declare (ignore args)) + t))) + ;; + ;; If the first character is a caret then set the anchored + ;; flags and remove if from the expression string. + ;; + (cond ((eql (char source 0) #^) + (setf source (subseq source 1)) + (setf anchored t))) + ;; + ;; If the first sequence is .* then also set the anchored flags. + ;; (This is purely for optimization, it will work without this). + ;; + (if (>= (length source) 2) + (if (string= source ".*" :start1 0 :end1 2) + (setf anchored t))) + ;; + ;; Also, If this is not an anchored search and the first character is + ;; a literal, then do a quick scan to see if it is even in the string. + ;; If not then we can issue a quick nil, + ;; otherwise we can start the search at the matching character to skip + ;; the checks of the non-matching characters anyway. + ;; + ;; If I really wanted to speed up this section of code it would be + ;; easy to recognize the case of a fairly long multi-character literal + ;; and generate a Boyer-Moore search for the entire literal. + ;; + ;; I generate the code to do a loop because on CMU Lisp this is about + ;; twice as fast a calling position. + ;; + (if (and (not anchored) + (not (position (char source 0) *regex-special-chars*)) + (not (and (> (length source) 1) + (position (char source 1) *regex-special-chars*)))) + (setf fast-first `((if (not (dotimes (i length nil) + (if (eql (char string i) + ,(char source 0)) + (return (setf start i))))) + (return-from final-return nil))))) + ;; + ;; Generate the very first expression to save the starting index + ;; so that group 0 will be the entire string matched always + ;; + (add-exp '((setf (aref *regex-groups* 0) + (list index nil)))) + ;; + ;; Loop over each character in the regular expression building the + ;; expression list as we go. + ;; + (do ((eindex 0 (1+ eindex))) + ((= eindex (length source))) + (let ((current (char source eindex))) + (info "Now processing character ~A index = ~A~%" current eindex) + (case current + ((#.) + ;; + ;; Generate code for a single wild character + ;; + (add-exp '((if (>= index length) + (return-from compare nil) + (incf index))))) + ((#$) + ;; + ;; If this is the last character of the expression then + ;; anchor the end of the expression, otherwise let it slide + ;; as a standard character (even though it should be quoted). + ;; + (if (= eindex (1- (length source))) + (add-exp '((if (not (= index length)) + (return-from compare nil)))) + (add-exp '((if (not (and (< index length) + (eql (char string index) #$))) + (return-from compare nil) + (incf index)))))) + ((#*) + (add-exp '(ASTRISK))) + + ((#+) + (add-exp '(PLUS))) + + ((#?) + (add-exp '(QUESTION))) + + ((#() + ;; + ;; Start a grouping. + ;; + (incf group) + (push group group-stack) + (add-exp `((setf (aref *regex-groups* ,(1- group)) + (list index nil)))) + (add-exp `(,group))) + ((#)) + ;; + ;; End a grouping + ;; + (let ((group (pop group-stack))) + (add-exp `((setf (cadr (aref *regex-groups* ,(1- group))) + index))) + (add-exp `(,(- group))))) + ((#[) + ;; + ;; Start of a range operation. + ;; Generate a bit-vector that has one bit per possible character + ;; and then on each character or range, set the possible bits. + ;; + ;; If the first character is carat then invert the set. + (let* ((invert (eql (char source (1+ eindex)) #^)) + (bitstring (make-array 256 :element-type 'bit + :initial-element + (if invert 1 0))) + (set-char (if invert 0 1))) + (if invert (incf eindex)) + (do ((x (1+ eindex) (1+ x))) + ((eql (char source x) #]) (setf eindex x)) + (info "Building range with character ~A~%" (char source x)) + (cond ((and (eql (char source (1+ x)) #-) + (not (eql (char source (+ x 2)) #]))) + (if (>= (char-code (char source x)) + (char-code (char source (+ 2 x)))) + (error "Invalid range "~A-~A". Ranges must be in acending order" + (char source x) (char source (+ 2 x)))) + (do ((j (char-code (char source x)) (1+ j))) + ((> j (char-code (char source (+ 2 x)))) + (incf x 2)) + (info "Setting bit for char ~A code ~A~%" (code-char j) j) + (setf (sbit bitstring j) set-char))) + (t + (cond ((not (eql (char source x) #])) + (let ((char (char source x))) + ;; + ;; If the character is quoted then find out what + ;; it should have been + ;; + (if (eql (char source x) #\ ) + (let ((length)) + (multiple-value-setq (char length) + (regex-quoted (subseq source x) invert)) + (incf x length))) + (info "Setting bit for char ~A code ~A~%" char (char-code char)) + (if (not (vectorp char)) + (setf (sbit bitstring (char-code (char source x))) set-char) + (bit-ior bitstring char t)))))))) + (add-exp `((let ((range ,bitstring)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil))))))) + ((#\ ) + ;; + ;; Intreprete the next character as a special, range, octal, group or + ;; just the character itself. + ;; + (let ((length) + (value)) + (multiple-value-setq (value length) + (regex-quoted (subseq source (1+ eindex)) nil)) + (cond ((listp value) + (add-exp value)) + ((characterp value) + (add-exp `((if (not (and (< index length) + (eql (char string index) + ,value))) + (return-from compare nil) + (incf index))))) + ((vectorp value) + (add-exp `((let ((range ,value)) + (if (>= index length) + (return-from compare nil)) + (if (= 1 (sbit range (char-code (char string index)))) + (incf index) + (return-from compare nil))))))) + (incf eindex length))) + (t + ;; + ;; We have a literal character. + ;; Scan to see how many we have and if it is more than one + ;; generate a string= verses as single eql. + ;; + (let* ((lit "") + (term (dotimes (litindex (- (length source) eindex) nil) + (let ((litchar (char source (+ eindex litindex)))) + (if (position litchar *regex-special-chars*) + (return litchar) + (progn + (info "Now adding ~A index ~A to lit~%" litchar + litindex) + (setf lit (concatenate 'string lit + (string litchar))))))))) + (if (= (length lit) 1) + (add-exp `((if (not (and (< index length) + (eql (char string index) ,current))) + (return-from compare nil) + (incf index)))) + ;; + ;; If we have a multi-character literal then we must + ;; check to see if the next character (if there is one) + ;; is an astrisk or a plus or a question mark. If so then we must not use this + ;; character in the big literal. + (progn + (if (or (eql term #*) + (eql term #+) + (eql term #?)) + (setf lit (subseq lit 0 (1- (length lit))))) + (add-exp `((if (< length (+ index ,(length lit))) + (return-from compare nil)) + (if (not (string= string ,lit :start1 index + :end1 (+ index ,(length lit)))) + (return-from compare nil) + (incf index ,(length lit))))))) + (incf eindex (1- (length lit)))))))) + ;; + ;; Plug end of list to return t. If we made it this far then + ;; We have matched! + (add-exp '((setf (cadr (aref *regex-groups* 0)) + index))) + (add-exp '((return-from final-return t))) + ;; +;;; (print expression) + ;; + ;; Now take the expression list and turn it into a lambda expression + ;; replacing the special flags with lisp code. + ;; For example: A BEGIN needs to be replace by an expression that + ;; saves the current index, then evaluates everything till it gets to + ;; the END then save the new index if it didn't fail. + ;; On an ASTRISK I need to take the previous expression and wrap + ;; it in a do that will evaluate the expression till an error + ;; occurs and then another do that encompases the remainder of the + ;; regular expression and iterates decrementing the index by one + ;; of the matched expression sizes and then returns nil. After + ;; the last expression insert a form that does a return t so that + ;; if the entire nested sub-expression succeeds then the loop + ;; is broken manually. + ;; + (setf result (copy-tree nil)) + ;; + ;; Reversing the current expression makes building up the + ;; lambda list easier due to the nexting of expressions when + ;; and astrisk has been encountered. + (setf expression (reverse expression)) + (do ((elt 0 (1+ elt))) + ((>= elt (length expression))) + (let ((piece (nth elt expression))) + ;; + ;; Now check for PLUS, if so then ditto the expression and then let the + ;; ASTRISK below handle the rest. + ;; + (cond ((eql piece 'PLUS) + (cond ((listp (nth (1+ elt) expression)) + (setf result (append (list (nth (1+ elt) expression)) + result))) + ;; + ;; duplicate the entire group + ;; NOTE: This hasn't been implemented yet!! + (t + (error "GROUP repeat hasn't been implemented yet~%"))))) + (cond ((listp piece) ;Just append the list + (setf result (append (list piece) result))) + ((eql piece 'QUESTION) ; Wrap it in a block that won't fail + (cond ((listp (nth (1+ elt) expression)) + (setf result + (append `((progn (block compare + ,(nth (1+ elt) + expression)) + t)) + result)) + (incf elt)) + ;; + ;; This is a QUESTION on an entire group which + ;; hasn't been implemented yet!!! + ;; + (t + (error "Optional groups not implemented yet~%")))) + ((or (eql piece 'ASTRISK) ; Do the wild thing! + (eql piece 'PLUS)) + (cond ((listp (nth (1+ elt) expression)) + ;; + ;; This is a single character wild card so + ;; do the simple form. + ;; + (setf result + `((let ((oindex index)) + (block compare + (do () + (nil) + ,(nth (1+ elt) expression))) + (do ((start index (1- start))) + ((< start oindex) nil) + (let ((index start)) + (block compare + ,@result)))))) + (incf elt)) + (t + ;; + ;; This is a subgroup repeated so I must build + ;; the loop using several values. + ;; + )) + ) + (t t)))) ; Just ignore everything else. + ;; + ;; Now wrap the result in a lambda list that can then be + ;; invoked or compiled, however the user wishes. + ;; + (if anchored + (setf result + `(lambda (string &key (start 0) (end (length string))) + (setf *regex-groupings* ,group) + (block final-return + (block compare + (let ((index start) + (length end)) + ,@result))))) + (setf result + `(lambda (string &key (start 0) (end (length string))) + (setf *regex-groupings* ,group) + (block final-return + (let ((length end)) + ,@fast-first + (do ((marker start (1+ marker))) + ((> marker end) nil) + (let ((index marker)) + (if (block compare + ,@result) + (return t))))))))))) + +;; (provide 'nregex)
Added: branches/trunk-reorg/thirdparty/slime/sbcl-pprint-patch.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/sbcl-pprint-patch.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/sbcl-pprint-patch.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -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
Added: branches/trunk-reorg/thirdparty/slime/slime-autoloads.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/slime-autoloads.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/slime-autoloads.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,50 @@ +;;; slime-autoloads.el --- autoload definitions for SLIME + +;; Copyright (C) 2007 Helmut Eller + +;; This file is protected by the GNU GPLv2 (or later), as distributed +;; with GNU Emacs. + +;;; Commentary: + +;; This code defines the necessary autoloads, so that we don't need to +;; load everything from .emacs. + +;;; Code: + +(autoload 'slime "slime" + "Start a Lisp subprocess and connect to its Swank server." t) + +(autoload 'slime-mode "slime" + "SLIME: The Superior Lisp Interaction (Minor) Mode for Emacs." t) + +(autoload 'slime-connect "slime" + "Connect to a running Swank server." t) + +(autoload 'hyperspec-lookup "hyperspec" nil t) + +(autoload 'slime-lisp-mode-hook "slime") +(autoload 'slime-scheme-mode-hook "slime") + +(defvar slime-lisp-modes '(lisp-mode)) + +(defun slime-setup (&optional contribs) + "Setup Emacs so that lisp-mode buffers always use SLIME. +CONTRIBS is a list of contrib packages to load." + (when (member 'lisp-mode slime-lisp-modes) + (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) + (setq slime-setup-contribs contribs) + (add-hook 'slime-load-hook 'slime-setup-contribs)) + +(defvar slime-setup-contribs nil) + +(defun slime-setup-contribs () + (dolist (c slime-setup-contribs) + (require c) + (let ((init (intern (format "%s-init" c)))) + (when (fboundp init) + (funcall init))))) + +(provide 'slime-autoloads) + +;;; slime-autoloads.el ends here
Added: branches/trunk-reorg/thirdparty/slime/slime.el =================================================================== --- branches/trunk-reorg/thirdparty/slime/slime.el 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/slime.el 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,9543 @@ +;;; slime.el --- Superior Lisp Interaction Mode for Emacs +;; +;;;; License +;; Copyright (C) 2003 Eric Marsden, 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 +;; 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. + + +;;;; Commentary +;; +;; This file contains extensions for programming in Common Lisp. The +;; main features are: +;; +;; A socket-based communication/RPC interface between Emacs and +;; Lisp. +;; +;; The `slime-mode' minor-mode complementing `lisp-mode'. This new +;; mode includes many commands for interacting with the Common Lisp +;; process. +;; +;; Common Lisp REPL (Read-Eval-Print Loop) written in Emacs Lisp, +;; similar to `ielm'. +;; +;; Common Lisp debugger written in Emacs Lisp. The debugger pops up +;; an Emacs buffer similar to the Emacs/Elisp debugger. +;; +;; Trapping compiler messages and creating annotations in the source +;; file on the appropriate forms. +;; +;; SLIME is compatible with GNU Emacs 20 and 21 and XEmacs 21. In +;; order to run SLIME requires a supporting Lisp server called +;; Swank. Swank is distributed with slime.el and will automatically be +;; started in a normal installation. + + +;;;; Dependencies and setup + +(eval-and-compile + (require 'cl) + (unless (fboundp 'define-minor-mode) + (require 'easy-mmode) + (defalias 'define-minor-mode 'easy-mmode-define-minor-mode))) +(require 'comint) +(require 'timer) +(require 'pp) +(require 'hideshow) +(require 'hyperspec) +(require 'font-lock) +(when (featurep 'xemacs) + (require 'overlay)) +(require 'easymenu) + +(defvar slime-lisp-modes '(lisp-mode)) + +(defun slime-setup (&optional contribs) + "Setup Emacs so that lisp-mode buffers always use SLIME. +CONTRIBS is a list of contrib packages to load." + (when (member 'lisp-mode slime-lisp-modes) + (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) + (dolist (c contribs) + (require c) + (let ((init (intern (format "%s-init" c)))) + (when (fboundp init) + (funcall init))))) + +(defun slime-lisp-mode-hook () + (slime-mode 1) + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function)) + +(eval-and-compile + (defvar slime-path + (let ((path (or (locate-library "slime") load-file-name))) + (and path (file-name-directory path))) + "Directory containing the Slime package. +This is used to load the supporting Common Lisp library, Swank. +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 +;; +;;;;; slime + +(defgroup slime nil + "Interaction with the Superior Lisp Environment." + :prefix "slime-" + :group 'applications) + +;;;;; slime-ui + +(defgroup slime-ui nil + "Interaction with the Superior Lisp Environment." + :prefix "slime-" + :group 'slime) + +(defcustom slime-truncate-lines t + "Set `truncate-lines' in popup buffers. +This applies to buffers that present lines as rows of data, such as +debugger backtraces and apropos listings." + :type 'boolean + :group 'slime-ui) + +(defcustom slime-update-modeline-package t + "Automatically update the Lisp package name in the minibuffer. +This is done with a text-search that runs on an idle timer." + :type 'boolean + :group 'slime-ui) + +(defcustom slime-kill-without-query-p nil + "If non-nil, kill SLIME processes without query when quitting Emacs. +This applies to the *inferior-lisp* buffer and the network connections." + :type 'boolean + :group 'slime-ui) + +;;;;; slime-lisp + +(defgroup slime-lisp nil + "Lisp server configuration." + :prefix "slime-" + :group 'slime) + +(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 +slime.el, but could also be set to an absolute filename." + :type 'string + :group 'slime-lisp) + +(defcustom slime-connected-hook nil + "List of functions to call when SLIME connects to Lisp." + :type 'hook + :group 'slime-lisp) + +(defcustom slime-filename-translations nil + "Assoc list of hostnames and filename translation functions. +Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP). + +HOSTNAME-REGEXP is a regexp which is applied to the connection's +slime-machine-instance. If HOSTNAME-REGEXP maches then the +corresponding TO-LISP and FROM-LISP functions will be used to +translate emacs filenames and lisp filenames. + +TO-LISP will be passed the filename of an emacs buffer and must +return a string which the underlying lisp understandas as a +pathname. FROM-LISP will be passed a pathname as returned by the +underlying lisp and must return something that emacs will +understand as a filename (this string will be passed to +find-file). + +This list will be traversed in order, so multiple matching +regexps are possible. + +Example: + +Assuming you run emacs locally and connect to slime running on +the machine 'soren' and you can connect with the username +'animaliter': + + (push (list "^soren$" + (lambda (emacs-filename) + (subseq emacs-filename (length "/ssh:animaliter@soren:"))) + (lambda (lisp-filename) + (concat "/ssh:animaliter@soren:" lisp-filename))) + slime-filename-translations) + +See also `slime-create-filename-translator'." + :type '(repeat (list :tag "Host description" + (regexp :tag "Hostname regexp") + (function :tag "To lisp function") + (function :tag "From lisp function"))) + :group 'slime-lisp) + +(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 + +(defgroup slime-mode nil + "Settings for slime-mode Lisp source buffers." + :prefix "slime-" + :group 'slime) + +(defcustom slime-edit-definition-fallback-function nil + "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-tag', +`slime-find-tag-if-tags-table-visited', or +`slime-edit-definition-with-etags'." + :type 'symbol + :group 'slime-mode-mode + :options '(nil + slime-edit-definition-with-etags + slime-find-tag-if-tags-table-visited + find-tag)) + +(defcustom slime-complete-symbol-function 'slime-simple-complete-symbol + "*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-space-information-p t + "Have the SPC key offer arglist information." + :type 'boolean + :group 'slime-mode) + +;;;;; slime-mode-faces + +(defgroup slime-mode-faces nil + "Faces in slime-mode source code buffers." + :prefix "slime-" + :group 'slime-mode) + +(defun slime-underline-color (color) + "Return a legal value for the :underline face attribute based on COLOR." + ;; In XEmacs the :underline attribute can only be a boolean. + ;; In GNU it can be the name of a colour. + (if (featurep 'xemacs) + (if color t nil) + color)) + +(defface slime-error-face + `((((class color) (background light)) + (:underline ,(slime-underline-color "red"))) + (((class color) (background dark)) + (:underline ,(slime-underline-color "red"))) + (t (:underline t))) + "Face for errors from the compiler." + :group 'slime-mode-faces) + +(defface slime-warning-face + `((((class color) (background light)) + (:underline ,(slime-underline-color "orange"))) + (((class color) (background dark)) + (:underline ,(slime-underline-color "coral"))) + (t (:underline t))) + "Face for warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-style-warning-face + `((((class color) (background light)) + (:underline ,(slime-underline-color "brown"))) + (((class color) (background dark)) + (:underline ,(slime-underline-color "gold"))) + (t (:underline t))) + "Face for style-warnings from the compiler." + :group 'slime-mode-faces) + +(defface slime-note-face + `((((class color) (background light)) + (:underline ,(slime-underline-color "brown4"))) + (((class color) (background dark)) + (:underline ,(slime-underline-color "light goldenrod"))) + (t (:underline t))) + "Face for notes from the compiler." + :group 'slime-mode-faces) + +(defun slime-face-inheritance-possible-p () + "Return true if the :inherit face attribute is supported." + (assq :inherit custom-face-attributes)) + +(defface slime-highlight-face + (if (slime-face-inheritance-possible-p) + '((t (:inherit highlight :underline nil))) + '((((class color) (background light)) + (:background "darkseagreen2")) + (((class color) (background dark)) + (:background "darkolivegreen")) + (t (:inverse-video t)))) + "Face for compiler notes while selected." + :group 'slime-mode-faces) + +;;;;; sldb + +(defgroup slime-debugger nil + "Backtrace options and fontification." + :prefix "sldb-" + :group 'slime) + +(defmacro define-sldb-faces (&rest faces) + "Define the set of SLDB faces. +Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES). +NAME is a symbol; the face will be called sldb-NAME-face. +DESCRIPTION is a one-liner for the customization buffer. +PROPERTIES specifies any default face properties." + `(progn ,@(loop for face in faces + collect `(define-sldb-face ,@face)))) + +(defmacro define-sldb-face (name description &optional default) + (let ((facename (intern (format "sldb-%s-face" (symbol-name name))))) + `(defface ,facename + (list (list t ,default)) + ,(format "Face for %s." description) + :group 'slime-debugger))) + +(define-sldb-faces + (topline "the top line describing the error") + (condition "the condition class") + (section "the labels of major sections in the debugger buffer") + (frame-label "backtrace frame numbers") + (restart-type "restart names." + (if (slime-face-inheritance-possible-p) + '(:inherit font-lock-keyword-face))) + (restart "restart descriptions") + (restart-number "restart numbers (correspond to keystrokes to invoke)" + '(:bold t)) + (frame-line "function names and arguments in the backtrace") + (detailed-frame-line + "function names and arguments in a detailed (expanded) frame") + (local-name "local variable names") + (local-value "local variable values") + (catch-tag "catch tags")) + +;;;;; slime-repl + +(defgroup slime-repl nil + "The Read-Eval-Print Loop (*slime-repl* buffer)." + :prefix "slime-repl-" + :group 'slime) + +(defcustom slime-repl-shortcut-dispatch-char ?, + "Character used to distinguish repl commands from lisp forms." + :type '(character) + :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))) + '((((class color) (background light)) (:foreground "Purple")) + (((class color) (background dark)) (:foreground "Cyan")) + (t (:weight bold)))) + "Face for the prompt in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-output-face + (if (slime-face-inheritance-possible-p) + '((t (:inherit font-lock-string-face))) + '((((class color) (background light)) (:foreground "RosyBrown")) + (((class color) (background dark)) (:foreground "LightSalmon")) + (t (:slant italic)))) + "Face for Lisp output in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-input-face + '((t (:bold t))) + "Face for previous input in the SLIME REPL." + :group 'slime-repl) + +(defface slime-repl-result-face + '((t ())) + "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-mode + +(define-minor-mode slime-mode + "\<slime-mode-map>\ +SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode). + +Commands to compile the current buffer's source file and visually +highlight any resulting compiler notes and warnings: +\[slime-compile-and-load-file] - Compile and load the current buffer's file. +\[slime-compile-file] - Compile (but not load) the current buffer's file. +\[slime-compile-defun] - Compile the top-level form at point. + +Commands for visiting compiler notes: +\[slime-next-note] - Goto the next form with a compiler note. +\[slime-previous-note] - Goto the previous form with a compiler note. +\[slime-remove-notes] - Remove compiler-note annotations in buffer. + +Finding definitions: +\[slime-edit-definition] - Edit the definition of the function called at point. +\[slime-pop-find-definition-stack] - Pop the definition stack to go back from a definition. + +Documentation commands: +\[slime-describe-symbol] - Describe symbol. +\[slime-apropos] - Apropos search. +\[slime-disassemble-symbol] - Disassemble a function. + +Evaluation commands: +\[slime-eval-defun] - Evaluate top-level from containing point. +\[slime-eval-last-expression] - Evaluate sexp before point. +\[slime-pprint-eval-last-expression] - Evaluate sexp before point, pretty-print result. + +Full set of commands: +\{slime-mode-map}" + nil + nil + ;; Fake binding to coax `define-minor-mode' to create the keymap + '((" " 'undefined))) + +(make-variable-buffer-local + (defvar slime-modeline-package nil + "The Lisp package to show in the modeline. +This is automatically updated based on the buffer/point.")) + +(defun slime-update-modeline-package () + (ignore-errors + (when (and slime-update-modeline-package + (memq major-mode slime-lisp-modes) + slime-mode) + (let ((package (slime-current-package))) + (when package + (setq slime-modeline-package + (slime-pretty-package-name package))))))) + +(defun slime-pretty-package-name (name) + "Return a pretty version of a package name NAME." + (let ((name (cond ((string-match "^:\(.*\)$" name) + (match-string 1 name)) + ((string-match "^"\(.*\)"$" name) + (match-string 1 name)) + (t name)))) + (format "%s" (read name)))) + +(when slime-update-modeline-package + (run-with-idle-timer 0.2 0.2 'slime-update-modeline-package)) + +;; Setup the mode-line to say when we're in slime-mode, and which CL +;; package we think the current buffer belongs to. +(add-to-list 'minor-mode-alist + '(slime-mode + (" Slime" + ((slime-modeline-package (":" slime-modeline-package) "") + slime-state-name)))) + +(defun slime-input-complete-p (start end) + "Return t if the region from START to END contains a complete sexp." + (save-excursion + (goto-char start) + (cond ((looking-at "\s *['`#]?[("]") + (ignore-errors + (save-restriction + (narrow-to-region start end) + ;; Keep stepping over blanks and sexps until the end of + ;; buffer is reached or an error occurs. Tolerate extra + ;; close parens. + (loop do (skip-chars-forward " \t\r\n)") + until (eobp) + do (forward-sexp)) + t))) + (t t)))) + + +;;;;; Key bindings + +;; See `slime-define-key' below for keyword meanings. +(defvar slime-keys + '(;; Compiler notes + ("\M-p" slime-previous-note) + ("\M-n" slime-next-note) + ("\M-c" slime-remove-notes :prefixed t) + ("\C-k" slime-compile-and-load-file :prefixed t) + ("\M-k" slime-compile-file :prefixed t) + ("\C-c" slime-compile-defun :prefixed t) + ("\C-l" slime-load-file :prefixed t) + ;; Editing/navigating + ("\M-\C-i" slime-complete-symbol :inferior t) + ("\C-i" slime-complete-symbol :prefixed t :inferior t) + ("\M-." slime-edit-definition :inferior t :sldb t) + ("\C-x4." slime-edit-definition-other-window :inferior t :sldb t) + ("\C-x5." slime-edit-definition-other-frame :inferior t :sldb t) + ("\M-," slime-pop-find-definition-stack :inferior t :sldb t) + ;; Evaluating + ("\C-x\C-e" slime-eval-last-expression :inferior t) + ("\C-x\M-e" slime-eval-last-expression-display-output :inferior t) + ("\C-p" slime-pprint-eval-last-expression :prefixed t :inferior t) + ("\C-r" slime-eval-region :prefixed t :inferior t) + ("\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) + ("\M-g" slime-quit :prefixed t :inferior t :sldb t) + ;; Documentation + (" " slime-space :inferior t) + ("\C-f" slime-describe-function :prefixed t :inferior t :sldb t) + ("\M-d" slime-disassemble-symbol :prefixed t :inferior t :sldb t) + ("\C-t" slime-toggle-trace-fdefinition :prefixed t :sldb t) + ("\C-u" slime-undefine-function :prefixed t) + ("\C-m" slime-macroexpand-1 :prefixed t :inferior t) + ("\M-m" slime-macroexpand-all :prefixed t :inferior t) + ("\M-0" slime-restore-window-configuration :prefixed t :inferior t) + ([(control meta ?.)] slime-next-location :inferior t) + ("~" slime-sync-package-and-default-directory :prefixed t :inferior t) + ("\M-p" slime-repl-set-package :prefixed t :inferior t) + ;; Cross reference + ("<" slime-list-callers :prefixed t :inferior t :sldb t) + (">" slime-list-callees :prefixed t :inferior t :sldb t) + ;; "Other" + ("\I" slime-inspect :prefixed t :inferior t :sldb t) + ("\C-]" slime-close-all-parens-in-sexp :prefixed t :inferior t :sldb t) + ("\C-xt" slime-list-threads :prefixed t :inferior t :sldb t) + ("\C-xc" slime-list-connections :prefixed t :inferior t :sldb t) + ;; ;; Shadow unwanted bindings from inf-lisp + ;; ("\C-a" slime-nop :prefixed t :inferior t :sldb t) + ;; ("\C-v" slime-nop :prefixed t :inferior t :sldb t) + )) + +(defun slime-nop () + "The null command. Used to shadow currently-unused keybindings." + (interactive) + (call-interactively 'undefined)) + +(defvar slime-doc-map (make-sparse-keymap) + "Keymap for documentation commands. Bound to a prefix key.") + +(defvar slime-doc-bindings + '((?a slime-apropos) + (?z slime-apropos-all) + (?p slime-apropos-package) + (?d slime-describe-symbol) + (?f slime-describe-function) + (?h slime-hyperspec-lookup) + (?~ common-lisp-hyperspec-format))) + +(defvar slime-who-map (make-sparse-keymap) + "Keymap for who-xref commands. Bound to a prefix key.") + +(defvar slime-who-bindings + '((?c slime-who-calls) + (?w slime-calls-who) + (?r slime-who-references) + (?b slime-who-binds) + (?s slime-who-sets) + (?m slime-who-macroexpands) + (?a slime-who-specializes))) + +;; Maybe a good idea, maybe not.. +(defvar slime-prefix-key "\C-c" + "The prefix key to use in SLIME keybinding sequences.") + +(defun* slime-define-key (key command &key prefixed inferior) + "Define a keybinding of KEY for COMMAND. +If PREFIXED is non-nil, `slime-prefix-key' is prepended to KEY." + (when prefixed + (setq key (concat slime-prefix-key key))) + (define-key slime-mode-map key command)) + +(defun slime-init-keymaps () + "(Re)initialize the keymaps for `slime-mode'." + (interactive) + (loop for (key command . keys) in slime-keys + do (apply #'slime-define-key key command :allow-other-keys t keys)) + ;; Documentation + (setq slime-doc-map (make-sparse-keymap)) + (loop for (key command) in slime-doc-bindings + do (progn + ;; We bind both unmodified and with control. + (define-key slime-doc-map (vector key) command) + (unless (equal key ?h) ; But don't bind C-h + (let ((modified (slime-control-modified-char key))) + (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 + (setq slime-who-map (make-sparse-keymap)) + (loop for (key command) in slime-who-bindings + do (progn + ;; We bind both unmodified and with control. + (define-key slime-who-map (vector key) command) + (let ((modified (slime-control-modified-char key))) + (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? + (read (format "?\C-%c" char))) + +(slime-init-keymaps) + + +;;;; Setup initial `slime-mode' hooks + +(make-variable-buffer-local + (defvar slime-pre-command-actions nil + "List of functions to execute before the next Emacs command. +This list of flushed between commands.")) + +(defun slime-pre-command-hook () + "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)) + +(defun slime-post-command-hook () + (when (null pre-command-hook) ; sometimes this is lost + (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'." + (add-local-hook 'pre-command-hook 'slime-pre-command-hook) + (add-local-hook 'post-command-hook 'slime-post-command-hook)) + + +;;;; Framework'ey bits +;;; +;;; This section contains some standard SLIME idioms: basic macros, +;;; ways of showing messages to the user, etc. All the code in this +;;; file should use these functions when applicable. +;;; +;;;;; Syntactic sugar + +(defmacro* when-let ((var value) &rest body) + "Evaluate VALUE, and if the result is non-nil bind it to VAR and +evaluate BODY. + +(fn (VAR VALUE) &rest BODY)" + `(let ((,var ,value)) + (when ,var ,@body))) + +(put 'when-let 'lisp-indent-function 1) + +(defmacro with-lexical-bindings (variables &rest body) + "Execute BODY with VARIABLES in lexical scope." + `(lexical-let ,(mapcar (lambda (variable) (list variable variable)) + variables) + ,@body)) + +(put 'with-lexical-bindings 'lisp-indent-function 1) + +(defmacro destructure-case (value &rest patterns) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (gensym "op-")) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (case ,operator + ,@(mapcar (lambda (clause) + (if (eq (car clause) t) + `(t ,@(cdr clause)) + (destructuring-bind ((op &rest rands) &rest body) clause + `(,op (destructuring-bind ,rands ,operands + . ,body))))) + patterns) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "Elisp destructure-case failed: %S" ,tmp)))))))) + +(put 'destructure-case 'lisp-indent-function 1) + +(defmacro slime-define-keys (keymap &rest key-command) + "Define keys in KEYMAP. Each KEY-COMMAND is a list of (KEY COMMAND)." + `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c)) + key-command))) + +(put 'slime-define-keys 'lisp-indent-function 1) + +(defmacro* with-struct ((conc-name &rest slots) struct &body body) + "Like with-slots but works only for structs. +(fn (CONC-NAME &rest SLOTS) STRUCT &body BODY)" + (flet ((reader (slot) (intern (concat (symbol-name conc-name) + (symbol-name slot))))) + (let ((struct-var (gensym "struct"))) + `(let ((,struct-var ,struct)) + (symbol-macrolet + ,(mapcar (lambda (slot) + (etypecase slot + (symbol `(,slot (,(reader slot) ,struct-var))) + (cons `(,(first slot) (,(reader (second slot)) + ,struct-var))))) + slots) + . ,body))))) + +(put 'with-struct 'lisp-indent-function 2) + +;;;;; Very-commonly-used functions + +(defvar slime-message-function 'message) + +;; Interface +(defun slime-message (format &rest args) + "Like `message' but with special support for multi-line messages. +Single-line messages use the echo area." + (apply slime-message-function format args)) + +(when (or (featurep 'xemacs) + (= emacs-major-version 20)) + (setq slime-message-function 'slime-format-display-message)) + +(defun slime-format-display-message (format &rest args) + (slime-display-message (apply #'format format args) "*SLIME Note*")) + +(defun slime-display-message (message buffer-name) + "Display MESSAGE in the echo area or in BUFFER-NAME. +Use the echo area if MESSAGE needs only a single line. If the MESSAGE +requires more than one line display it in BUFFER-NAME and add a hook +to `slime-pre-command-actions' to remove the window before the next +command." + (when (get-buffer-window buffer-name) (delete-windows-on buffer-name)) + (cond ((or (string-match "\n" message) + (> (length message) (1- (frame-width)))) + (lexical-let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (erase-buffer) + (insert message) + (goto-char (point-min)) + (let ((win (slime-create-message-window))) + (set-window-buffer win (current-buffer)) + (shrink-window-if-larger-than-buffer + (display-buffer (current-buffer))))) + (push (lambda () (delete-windows-on buffer) (bury-buffer buffer)) + slime-pre-command-actions))) + (t (message "%s" message)))) + +(defun slime-create-message-window () + "Create a window at the bottom of the frame, above the minibuffer." + (let ((previous (previous-window (minibuffer-window)))) + (when (<= (window-height previous) (* 2 window-min-height)) + (save-selected-window + (select-window previous) + (enlarge-window (- (1+ (* 2 window-min-height)) + (window-height previous))))) + (split-window previous))) + +(defvar slime-background-message-function 'slime-display-oneliner) + +;; Interface +(defun slime-background-message (format-string &rest format-args) + "Display a message in passing. +This is like `slime-message', but less distracting because it +will never pop up a buffer or display multi-line messages. +It should be used for "background" messages such as argument lists." + (apply slime-background-message-function format-string format-args)) + +(defun slime-display-oneliner (format-string &rest format-args) + (let* ((msg (apply #'format format-string format-args))) + (unless (minibuffer-window-active-p (minibuffer-window)) + (message "%s" (slime-oneliner msg))))) + +(defun slime-oneliner (string) + "Return STRING truncated to fit in a single echo-area line." + (substring string 0 (min (length string) + (or (position ?\n string) most-positive-fixnum) + (1- (frame-width))))) + +;; Interface +(defun slime-set-truncate-lines () + "Apply `slime-truncate-lines' to the current buffer." + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +;; Interface +(defun slime-read-package-name (prompt &optional initial-value) + "Read a package name from the minibuffer, prompting with PROMPT." + (let ((completion-ignore-case t)) + (completing-read prompt (slime-bogus-completion-alist + (slime-eval + `(swank:list-all-package-names t))) + nil t initial-value))) + +;; Interface +(defun slime-read-symbol-name (prompt &optional query) + "Either read a symbol name or choose the one at point. +The user is prompted if a prefix argument is in effect, if there is no +symbol at point, or if QUERY is non-nil. + +This function avoids mistaking the REPL prompt for a symbol." + (cond ((or current-prefix-arg query (not (slime-symbol-name-at-point))) + (slime-read-from-minibuffer prompt (slime-symbol-name-at-point))) + (t (slime-symbol-name-at-point)))) + +;; Interface +(defmacro slime-propertize-region (props &rest body) + "Execute BODY and add PROPS to all the text it inserts. +More precisely, PROPS are added to the region between the point's +positions before and after executing BODY." + (let ((start (gensym))) + `(let ((,start (point))) + (prog1 (progn ,@body) + (add-text-properties ,start (point) ,props))))) + +(put 'slime-propertize-region 'lisp-indent-function 1) + +;; Interface +(defsubst slime-insert-propertized (props &rest args) + "Insert all ARGS and then add text-PROPS to the inserted text." + (slime-propertize-region props (apply #'insert args))) + +(defmacro slime-with-rigid-indentation (level &rest body) + "Execute BODY and then rigidly indent its text insertions. +Assumes all insertions are made at point." + (let ((start (gensym)) (l (gensym))) + `(let ((,start (point)) (,l ,(or level '(current-column)))) + (prog1 (progn ,@body) + (slime-indent-rigidly ,start (point) ,l))))) + +(put 'slime-with-rigid-indentation 'lisp-indent-function 1) + +(defun slime-indent-rigidly (start end column) + ;; Similar to `indent-rigidly' but doesn't inherit text props. + (save-excursion + (goto-char end) + (beginning-of-line) + (while (and (<= start (point)) + (progn + (save-excursion (insert-char ?\ column)) + (zerop (forward-line -1))))))) + +(defun slime-insert-indented (&rest strings) + "Insert all arguments rigidly indented." + (slime-with-rigid-indentation nil + (apply #'insert strings))) + +(defun slime-curry (fun &rest args) + `(lambda (&rest more) (apply ',fun (append ',args more)))) + +(defun slime-rcurry (fun &rest args) + `(lambda (&rest more) (apply ',fun (append more ',args)))) + +;;;;; Snapshots of current Emacs state + +;;; Window configurations do not save (and hence not restore) +;;; any narrowing that could be applied to a buffer. +;;; +;;; For this purpose, we introduce a superset of a window +;;; configuration that does include the necessary information to +;;; properly restore narrowing. +;;; +;;; We call this superset an Emacs Snapshot. + +(defstruct (slime-narrowing-configuration + (:conc-name slime-narrowing-configuration.)) + narrowedp beg end) + +(defstruct (slime-emacs-snapshot (:conc-name slime-emacs-snapshot.)) + window-configuration narrowing-configuration) + +(defun slime-current-narrowing-configuration (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (make-slime-narrowing-configuration :narrowedp (slime-buffer-narrowed-p) + :beg (point-min-marker) + :end (point-max-marker)))) + +(defun slime-set-narrowing-configuration (narrowing-cfg) + (when (slime-narrowing-configuration.narrowedp narrowing-cfg) + (narrow-to-region (slime-narrowing-configuration.beg narrowing-cfg) + (slime-narrowing-configuration.end narrowing-cfg)))) + +(defun slime-current-emacs-snapshot (&optional frame) + "Returns a snapshot of the current state of FRAME, or the +currently active frame if FRAME is not given respectively." + (with-current-buffer + (if frame + (window-buffer (frame-selected-window (selected-frame))) + (current-buffer)) + (make-slime-emacs-snapshot + :window-configuration (current-window-configuration frame) + :narrowing-configuration (slime-current-narrowing-configuration)))) + +(defun slime-set-emacs-snapshot (snapshot) + "Restores the state of Emacs according to the information saved +in SNAPSHOT." + (let ((window-cfg (slime-emacs-snapshot.window-configuration snapshot)) + (narrowing-cfg (slime-emacs-snapshot.narrowing-configuration snapshot))) + (set-window-configuration window-cfg) ; restores previously current buffer. + (slime-set-narrowing-configuration narrowing-cfg))) + +(defun slime-current-emacs-snapshot-fingerprint (&optional frame) + "Return a fingerprint of the current emacs snapshot. +Fingerprints are `equalp' if and only if they represent window +configurations that are very similar (same windows and buffers.) + +Unlike real window-configuration objects, fingerprints are not +sensitive to the point moving and they can't be restored." + (mapcar (lambda (window) (list window (window-buffer window))) + (slime-frame-windows frame))) + +(defun slime-frame-windows (&optional frame) + "Return the list of windows in FRAME." + (loop with last-window = (previous-window (frame-first-window frame)) + for window = (frame-first-window frame) then (next-window window) + collect window + until (eq window last-window))) + + +(defmacro save-restriction-if-possible (&rest body) + "Very similiarly to `save-restriction'. The only difference is +that it's not enforcing the restriction as strictly: It's only +enforced if `point' was not moved outside of the restriction +after executing BODY. + +Example: + + (progn (goto-line 1000) + (narrow-to-page) + (save-restriction-if-possible (widen) (goto-line 999))) + + In this case, the buffer is narrowed to the current page, and + point is on line 999. + + (progn (goto-char 1000) + (narrow-to-page) + (save-restriction-if-possible (widen) (goto-line 1))) + + Whereas in this case, the buffer is widened and point is on + line 1." + (let ((gcfg (gensym "NARROWING-CFG+")) + (gbeg (gensym "OLDBEG+")) + (gend (gensym "OLDEND+"))) + `(let ((,gcfg (slime-current-narrowing-configuration))) + (unwind-protect (progn ,@body) + (let ((,gbeg (slime-narrowing-configuration.beg ,gcfg)) + (,gend (slime-narrowing-configuration.end ,gcfg))) + (when (and (>= (point) ,gbeg) (<= (point) ,gend)) + (slime-set-narrowing-configuration ,gcfg))))))) + +(put 'save-restriction-if-possible 'lisp-indent-function 0) + +;;;;; Temporary popup buffers + +(make-variable-buffer-local + (defvar slime-temp-buffer-saved-emacs-snapshot nil + "The snapshot of the current state in Emacs before the temp-buffer +was displayed, so that this state can be restored later on. +Buffer local in temp-buffers.")) + +(make-variable-buffer-local + (defvar slime-temp-buffer-saved-fingerprint nil + "The emacs snapshot "fingerprint" after displaying the buffer.")) + +;; Interface +(defun* slime-get-temp-buffer-create (name &key mode noselectp reusep + emacs-snapshot) + "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 REUSEP is true and a buffer does already exist with name NAME, +then the buffer will be reused instead of being killed. + +If EMACS-SNAPSHOT is non-NIL, it's used to restore the previous +state of Emacs after closing the temporary buffer. Otherwise, the +current state will be saved and later restored. +" + (let ((snapshot (or emacs-snapshot (slime-current-emacs-snapshot))) + (buffer (get-buffer name))) + (when (and buffer (not reusep)) + (kill-buffer name) + (setq buffer nil)) + (with-current-buffer (or buffer (get-buffer-create name)) + (when mode + (let ((original-configuration slime-temp-buffer-saved-emacs-snapshot) + (original-fingerprint slime-temp-buffer-saved-fingerprint)) + (funcall mode) + (setq slime-temp-buffer-saved-emacs-snapshot original-configuration) + (setq slime-temp-buffer-saved-fingerprint original-fingerprint))) + (slime-temp-buffer-mode 1) + (let ((window (get-buffer-window (current-buffer)))) + (if window + (unless noselectp + (select-window window)) + (progn + (if noselectp + (display-buffer (current-buffer) t) + (pop-to-buffer (current-buffer)) + (selected-window)) + (setq slime-temp-buffer-saved-emacs-snapshot snapshot) + (setq slime-temp-buffer-saved-fingerprint + (slime-current-emacs-snapshot-fingerprint))))) + (current-buffer)))) + +;; Interface +(defmacro* slime-with-output-to-temp-buffer ((name &key mode reusep) + package &rest body) + "Similar to `with-output-to-temp-buffer'. +Also saves the current state of Emacs (window configuration &c), +and inherits the current `slime-connection' in a buffer-local +variable. Cf. `slime-get-temp-buffer-create'" + `(let ((connection (slime-connection)) + (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) + (goto-char (point-min)) + (slime-mode 1) + (set-syntax-table lisp-mode-syntax-table) + (setq buffer-read-only t))))) + +(put 'slime-with-output-to-temp-buffer 'lisp-indent-function 2) + +(define-minor-mode slime-temp-buffer-mode + "Mode for displaying read only stuff" + nil + " temp" + '(("q" . slime-temp-buffer-quit))) + +;; Interface +(defun slime-temp-buffer-quit (&optional kill-buffer-p) + "Get rid of the current (temp) buffer without asking. Restore the +window configuration unless it was changed since we last activated the buffer." + (interactive) + (let ((snapshot slime-temp-buffer-saved-emacs-snapshot) + (temp-buffer (current-buffer))) + (setq slime-temp-buffer-saved-emacs-snapshot nil) + (if (and snapshot (equalp (slime-current-emacs-snapshot-fingerprint) + slime-temp-buffer-saved-fingerprint)) + (slime-set-emacs-snapshot snapshot) + (bury-buffer)) + (when kill-buffer-p + (kill-buffer temp-buffer)))) + +;;;;; Filename translation +;;; +;;; Filenames passed between Emacs and Lisp should be translated using +;;; these functions. This way users who run Emacs and Lisp on separate +;;; machines have a chance to integrate file operations somehow. + +(defun slime-to-lisp-filename (filename) + "Translate the string FILENAME to a Lisp filename. +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-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)))) + + +;;;; Starting SLIME +;;; +;;; This section covers starting an inferior-lisp, compiling and +;;; starting the server, initiating a network connection. + +;;;;; Entry points + +;; 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.") + +(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) ...) + +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 + +Here's an example: + ((cmucl ("/opt/cmucl/bin/lisp" "-quiet") :init slime-init-command) + (acl ("acl7") :coding-system emacs-mule))") + +(defvar slime-default-lisp nil + "*The name of the default Lisp implementation. +See `slime-lisp-implementations'") + +(defvar slime-lisp-host "127.0.0.1" + "The default hostname (or IP address) to connect to.") + +;; dummy definitions for the compiler +(defvar slime-net-coding-system) +(defvar slime-net-processes) +(defvar slime-default-connection) + +(defun slime (&optional command coding-system) + "Start an inferior^_superior Lisp and connect to its Swank server." + (interactive) + (let ((inferior-lisp-program (or command inferior-lisp-program)) + (slime-net-coding-system (or coding-system slime-net-coding-system))) + (slime-start* (slime-read-interactive-args)))) + +(defvar slime-inferior-lisp-program-history '() + "History list of command strings. Used by `slime'.") + +(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) (slime-lisp-options)) + ((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-lisp-options (&optional name) + (let ((table slime-lisp-implementations)) + (assert (or (not name) table)) + (cond (table (slime-lookup-lisp-implementation slime-lisp-implementations + (or name slime-default-lisp + (car (car table))))) + (t (destructuring-bind (program &rest args) + (split-string inferior-lisp-program) + (list :program program :program-args args)))))) + +(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 + directory + (coding-system slime-net-coding-system) + (init 'slime-init-command) + name + (buffer "*inferior-lisp*") + init-function) + (let ((args (list :program program :program-args program-args :buffer buffer + :coding-system coding-system :init init :name name + :init-function init-function))) + (slime-check-coding-system coding-system) + (when (slime-bytecode-stale-p) + (slime-urge-bytecode-recompile)) + (let ((proc (slime-maybe-start-lisp program program-args + directory buffer))) + (slime-inferior-connect proc args) + (pop-to-buffer (process-buffer proc))))) + +(defun slime-start* (options) + (apply #'slime-start options)) + +(defun slime-connect (host port &optional coding-system) + "Connect to a running Swank server." + (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)) + (message "Connecting to Swank on port %S.." port) + (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." + (interactive (list (expand-file-name (buffer-file-name)) + (slime-find-buffer-package))) + (cond ((slime-connected-p) + (slime-load-file-set-package filename package)) + (t + (slime-start-and-init (slime-lisp-options) + (slime-curry #'slime-start-and-load + filename package))))) + +(defun slime-start-and-init (options fun) + (let* ((rest (plist-get options :init-function)) + (init (cond (rest `(lambda () (funcall ',rest) (funcall ',fun))) + (t fun)))) + (slime-start* (plist-put (copy-list options) :init-function init)))) + +(defun slime-load-file-set-package (filename package) + (let ((filename (slime-to-lisp-filename filename))) + (slime-eval-async `(swank:load-file-set-package ,filename ,package) + (lambda (package) + (when package + (slime-repl-set-package (second package))))))) + +;;;;; Start inferior lisp +;;; +;;; Here is the protocol for starting SLIME: +;;; +;;; 0. Emacs recompiles/reloads slime.elc if it exists and is stale. +;;; 1. Emacs starts an inferior Lisp process. +;;; 2. Emacs tells Lisp (via stdio) to load and start Swank. +;;; 3. Lisp recompiles the Swank if needed. +;;; 4. Lisp starts the Swank server and writes its TCP port to a temp file. +;;; 5. Emacs reads the temp file to get the port and then connects. +;;; 6. Emacs prints a message of warm encouragement for the hacking ahead. +;;; +;;; Between steps 2-5 Emacs polls for the creation of the temp file so +;;; that it can make the connection. This polling may continue for a +;;; fair while if Swank needs recompilation. + +(defvar slime-connect-retry-timer nil + "Timer object while waiting for an inferior-lisp to start.") + +;;; Recompiling bytecode: + +(defun slime-bytecode-stale-p () + "Return true if slime.elc is older than slime.el." + (when-let (libfile (locate-library "slime")) + (let* ((basename (file-name-sans-extension libfile)) + (sourcefile (concat basename ".el")) + (bytefile (concat basename ".elc"))) + (and (file-exists-p bytefile) + (file-newer-than-file-p sourcefile bytefile))))) + +(defun slime-recompile-bytecode () + "Recompile and reload slime. +Warning: don't use this in XEmacs, it seems to crash it!" + (interactive) + (let ((sourcefile (concat (file-name-sans-extension (locate-library "slime")) + ".el"))) + (byte-compile-file sourcefile t))) + +(defun slime-urge-bytecode-recompile () + "Urge the user to recompile slime.elc. +Return true if we have been given permission to continue." + (cond ((featurep 'xemacs) + ;; My XEmacs crashes and burns if I recompile/reload an elisp + ;; file from itself. So they have to do it themself. + (or (y-or-n-p "slime.elc is older than source. Continue? ") + (signal 'quit nil))) + ((y-or-n-p "slime.elc is older than source. Recompile first? ") + (slime-recompile-bytecode)) + (t))) + +(defun slime-abort-connection () + "Abort connection the current connection attempt." + (interactive) + (cond (slime-connect-retry-timer + (slime-cancel-connect-retry-timer) + (message "Cancelled connection attempt.")) + (t (error "Not connecting")))) + +;;; Starting the inferior Lisp and loading Swank: + +(defun slime-maybe-start-lisp (program program-args directory buffer) + "Return a new or existing inferior lisp process." + (cond ((not (comint-check-proc buffer)) + (slime-start-lisp program program-args directory 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 buffer)) + (t (slime-start-lisp program program-args + directory + (generate-new-buffer-name buffer))))) + +(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 (program program-args directory buffer) + "Does the same as `inferior-lisp' but less ugly. +Return the created process." + (with-current-buffer (get-buffer-create buffer) + (when directory + (cd (expand-file-name directory))) + (comint-mode) + (comint-exec (current-buffer) "inferior-lisp" program nil program-args) + (lisp-mode-variables t) + (let ((proc (get-buffer-process (current-buffer)))) + (slime-set-query-on-exit-flag proc) + proc))) + +(defun slime-inferior-connect (process args) + "Start a Swank server in the inferior Lisp and connect." + (slime-delete-swank-port-file 'quiet) + (slime-start-swank-server process args) + (slime-read-port-and-connect process nil)) + +(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." + (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 ,(expand-file-name 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 + (cond ((fboundp 'temp-directory) (temp-directory)) + ((boundp 'temporary-file-directory) temporary-file-directory) + (t "/tmp/"))) + (format "slime.%S" (emacs-pid)))) + +(defun slime-delete-swank-port-file (&optional quiet) + (condition-case data + (delete-file (slime-swank-port-file)) + (error + (ecase quiet + ((nil) (signal (car data) (cdr data))) + (quiet) + (message (message "Unable to delete swank port file %S" + (slime-swank-port-file))))))) + +(defun slime-read-port-and-connect (inferior-process retries) + (slime-cancel-connect-retry-timer) + (slime-attempt-connection inferior-process retries 1)) + +(defun slime-attempt-connection (process retries attempt) + ;; A small one-state machine to attempt a connection with + ;; timer-based retries. + (let ((file (slime-swank-port-file))) + (unless (active-minibuffer-window) + (message "Polling %S.. (Abort with `M-x slime-abort-connection'.)" file)) + (unless (slime-connected-p) + (slime-set-state (format "[polling:%S]" attempt))) + (slime-cancel-connect-retry-timer) + (cond ((and (file-exists-p file) + (> (nth 7 (file-attributes file)) 0)) ; file size + (let ((port (slime-read-swank-port)) + (args (slime-inferior-lisp-args process))) + (slime-delete-swank-port-file 'message) + (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 (and (file-exists-p file) + (zerop (nth 7 (file-attributes file)))) + (message "(Zero length port file)") + ;; the file may be in the filesystem but not yet written + (unless retries (setq retries 3))) + (setq slime-connect-retry-timer + (run-with-timer 0.3 nil + #'slime-timer-call #'slime-attempt-connection + process (and retries (1- retries)) + (1+ attempt))))))) + +(defun slime-timer-call (fun &rest args) + "Call function FUN with ARGS, reporting all errors. + +The default condition handler for timer functions (see +`timer-event-handler') ignores errors." + (condition-case data + (apply fun args) + (error (debug nil (list "Error in timer" fun args data))))) + +(defun slime-cancel-connect-retry-timer () + (when slime-connect-retry-timer + (cancel-timer slime-connect-retry-timer) + (setq slime-connect-retry-timer nil))) + +(defun slime-read-swank-port () + "Read the Swank server port number from the `slime-swank-port-file'." + (save-excursion + (with-temp-buffer + (insert-file-contents (slime-swank-port-file)) + (goto-char (point-min)) + (let ((port (read (current-buffer)))) + (assert (integerp port)) + port)))) + +(defun slime-hide-inferior-lisp-buffer () + "Display the REPL buffer instead of the *inferior-lisp* buffer." + (let* ((buffer (if (slime-process) + (process-buffer (slime-process)))) + (window (if buffer (get-buffer-window buffer))) + (repl-buffer (slime-output-buffer t)) + (repl-window (get-buffer-window repl-buffer))) + (when buffer + (bury-buffer buffer)) + (cond (repl-window + (when window + (delete-window window))) + (window + (set-window-buffer window repl-buffer)) + (t + (pop-to-buffer repl-buffer) + (goto-char (point-max)))))) + +;;; Words of encouragement + +(defun slime-user-first-name () + (let ((name (if (string= (user-full-name) "") + (user-login-name) + (user-full-name)))) + (string-match "^[^ ]*" name) + (capitalize (match-string 0 name)))) + +(defvar slime-words-of-encouragement + `("Let the hacking commence!" + "Hacks and glory await!" + "Hack and be merry!" + "Your hacking starts... NOW!" + "May the source be with you!" + "Take this REPL, brother, and may it serve you well." + "Lemonodor-fame is but a hack away!" + ,(format "%s, this could be the start of a beautiful program." + (slime-user-first-name))) + "Scientifically-proven optimal words of hackerish encouragement.") + +(defun slime-random-words-of-encouragement () + "Return a string of hackerish encouragement." + (eval (nth (random (length slime-words-of-encouragement)) + slime-words-of-encouragement))) + + +;;;; Networking +;;; +;;; This section covers the low-level networking: establishing +;;; connections and encoding/decoding protocol messages. +;;; +;;; Each SLIME protocol message beings with a 3-byte length header +;;; followed by an S-expression as text. The sexp must be readable +;;; both by Emacs and by Common Lisp, so if it contains any embedded +;;; code fragments they should be sent as strings. +;;; +;;; The set of meaningful protocol messages are not specified +;;; here. They are defined elsewhere by the event-dispatching +;;; functions in this file and in swank.lisp. + +(defvar slime-net-processes nil + "List of processes (sockets) connected to Lisps.") + +(defvar slime-net-process-close-hooks '() + "List of functions called when a slime network connection closes. +The functions are called with the process as their argument.") + +(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 +line of the file." + (condition-case err + (with-temp-buffer + (insert-file-contents "~/.slime-secret") + (goto-char (point-min)) + (buffer-substring (point-min) (line-end-position))) + (file-error nil))) + +;;; Interface +(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)) + (buffer (slime-make-net-buffer " *cl-connection*"))) + (push proc slime-net-processes) + (set-process-buffer proc buffer) + (set-process-filter proc 'slime-net-filter) + (set-process-sentinel proc 'slime-net-sentinel) + (slime-set-query-on-exit-flag proc) + (when (fboundp 'set-process-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)) + +(defun slime-make-net-buffer (name) + "Make a buffer suitable for a network process." + (let ((buffer (generate-new-buffer name))) + (with-current-buffer buffer + (buffer-disable-undo)) + buffer)) + +(defun slime-set-query-on-exit-flag (process) + "Set PROCESS's query-on-exit-flag to `slime-kill-without-query-p'." + (when slime-kill-without-query-p + ;; avoid byte-compiler warnings + (let ((fun (if (fboundp 'set-process-query-on-exit-flag) + 'set-process-query-on-exit-flag + 'process-kill-without-query))) + (funcall fun process nil)))) + +;;;;; 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))) + (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))) + +(defun slime-coding-system-cl-name (coding-system) + (third (slime-find-coding-system coding-system))) + +;;; Interface +(defun slime-net-send (sexp proc) + "Send a SEXP to Lisp over the socket PROC. +This is the lowest level of communication. The sexp will be READ and +EVAL'd by Lisp." + (let* ((msg (concat (slime-prin1-to-string sexp) "\n")) + (string (concat (slime-net-encode-length (length msg)) msg)) + (coding-system (cdr (process-coding-system proc)))) + (slime-log-event sexp) + (cond ((slime-safe-encoding-p coding-system string) + (process-send-string proc string)) + (t (error "Coding system %s not suitable for %S" + coding-system string))))) + +(defun slime-safe-encoding-p (coding-system string) + "Return true iff CODING-SYSTEM can safely encode STRING." + (if (featurep 'xemacs) + ;; FIXME: XEmacs encodes non-encodeable chars as ?~ automatically + t + (or (let ((candidates (find-coding-systems-string string)) + (base (coding-system-base coding-system))) + (or (equal candidates '(undecided)) + (memq base candidates))) + (and (not (multibyte-string-p string)) + (not (slime-coding-system-mulibyte-p coding-system)))))) + +(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)) + (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) + (slime-net-close process) + (slime-set-state "[not connected]" process)) + +;;; Socket input is handled by `slime-net-filter', which decodes any +;;; complete messages and hands them off to the event dispatcher. + +(defun slime-net-filter (process string) + "Accept output from the socket and process all complete messages." + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string)) + (slime-process-available-input process)) + +(defun slime-run-when-idle (function &rest args) + "Call FUNCTION as soon as Emacs is idle." + (apply #'run-at-time + (if (featurep 'xemacs) itimer-short-interval 0) + nil function args)) + +(defun slime-process-available-input (process) + "Process all complete messages that have arrived from Lisp." + (with-current-buffer (process-buffer process) + (while (slime-net-have-input-p) + (let ((event (slime-net-read-or-lose process)) + (ok nil)) + (slime-log-event event) + (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." + (goto-char (point-min)) + (and (>= (buffer-size) 6) + (>= (- (buffer-size) 6) (slime-net-decode-length)))) + +(defun slime-net-read-or-lose (process) + (condition-case error + (slime-net-read) + (error + (debug) + (slime-net-close process t) + (error "net-read error: %S" error)))) + +(defun slime-net-read () + "Read a message from the network buffer." + (goto-char (point-min)) + (let* ((length (slime-net-decode-length)) + (start (+ 6 (point))) + (end (+ start length))) + (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-no-properties (point) (+ (point) 6)) 16)) + +(defun slime-net-encode-length (n) + "Encode an integer into a 24-bit hex string." + (format "%06x" n)) + +(defun slime-prin1-to-string (sexp) + "Like `prin1-to-string' but don't octal-escape non-ascii characters. +This is more compatible with the CL reader." + (with-temp-buffer + (let ((print-escape-nonascii nil) + (print-escape-newlines nil)) + (prin1 sexp (current-buffer)) + (buffer-string)))) + + +;;;; Connections +;;; +;;; "Connections" are the high-level Emacs<->Lisp networking concept. +;;; +;;; Emacs has a connection to each Lisp process that it's interacting +;;; with. Typically there would only be one, but a user can choose to +;;; connect to many Lisps simultaneously. +;;; +;;; A connection consists of a control socket, optionally an extra +;;; socket dedicated to receiving Lisp output (an optimization), and a +;;; set of connection-local state variables. +;;; +;;; The state variables are stored as buffer-local variables in the +;;; control socket's process-buffer and are used via accessor +;;; functions. These variables include things like the *FEATURES* list +;;; and Unix Pid of the Lisp process. +;;; +;;; One connection is "current" at any given time. This is: +;;; `slime-dispatching-connection' if dynamically bound, or +;;; `slime-buffer-connection' if this is set buffer-local, or +;;; `slime-default-connection' otherwise. +;;; +;;; When you're invoking commands in your source files you'll be using +;;; `slime-default-connection'. This connection can be interactively +;;; reassigned via the connection-list buffer. +;;; +;;; When a command creates a new buffer it will set +;;; `slime-buffer-connection' so that commands in the new buffer will +;;; use the connection that the buffer originated from. For example, +;;; the apropos command creates the *Apropos* buffer and any command +;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the +;;; apropos search. REPL buffers are similarly tied to their +;;; respective connections. +;;; +;;; When Emacs is dispatching some network message that arrived from a +;;; connection it will dynamically bind `slime-dispatching-connection' +;;; so that the event will be processed in the context of that +;;; connection. +;;; +;;; This is mostly transparent. The user should be aware that he can +;;; set the default connection to pick which Lisp handles commands in +;;; Lisp-mode source buffers, and slime hackers should be aware that +;;; they can tie a buffer to a specific connection. The rest takes +;;; care of itself. + +(defvar slime-dispatching-connection nil + "Network process currently executing. +This is dynamically bound while handling messages from Lisp; it +overrides `slime-buffer-connection' and `slime-default-connection'.") + +(make-variable-buffer-local + (defvar slime-buffer-connection nil + "Network connection to use in the current buffer. +This overrides `slime-default-connection'.")) + +(defvar slime-default-connection nil + "Network connection to use by default. +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. +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) + (error "Not connected.")) + ((not (eq (process-status conn) 'open)) + (error "Connection closed.")) + (t conn)))) + +(defun slime-select-connection (process) + "Make PROCESS the default connection." + (setq slime-default-connection process)) + +(defmacro* slime-with-connection-buffer ((&optional process) &rest body) + "Execute BODY in the process-buffer of PROCESS. +If PROCESS is not specified, `slime-connection' is used. + +(fn (&optional PROCESS) &body BODY))" + `(with-current-buffer + (process-buffer (or ,process (slime-connection) + (error "No connection"))) + ,@body)) + +(put 'slime-with-connection-buffer 'lisp-indent-function 1) + +(defvar slime-state-name "[??]" + "Name of the current state of `slime-default-connection'. +Just used for informational display in the mode-line.") + +(defun slime-set-state (name &optional connection) + "Set the current connection's informational state name. +If this is the default connection then the state will be displayed in +the modeline." + (when (or (not (slime-connected-p)) + (eq (or connection (slime-connection)) slime-default-connection)) + (setq slime-state-name name) + (force-mode-line-update))) + +;;; Connection-local variables: + +(defmacro slime-def-connection-var (varname &rest initial-value-and-doc) + "Define a connection-local variable. +The value of the variable can be read by calling the function of the +same name (it must not be accessed directly). The accessor function is +setf-able. + +The actual variable bindings are stored buffer-local in the +process-buffers of connections. The accessor function refers to +the binding for `slime-connection'." + (let ((real-var (intern (format "%s:connlocal" varname)))) + `(progn + ;; Variable + (make-variable-buffer-local + (defvar ,real-var ,@initial-value-and-doc)) + ;; Accessor + (defun ,varname (&optional process) + (slime-with-connection-buffer (process) ,real-var)) + ;; Setf + (defsetf ,varname (&optional process) (store) + `(slime-with-connection-buffer (,process) + (setq (, (quote (, real-var))) (, store)) + (, store))) + '(, varname)))) + +(put 'slime-def-connection-var 'lisp-indent-function 2) + +;; Let's indulge in some pretty colours. +(unless (featurep 'xemacs) + (font-lock-add-keywords + 'emacs-lisp-mode + '(("(\(slime-def-connection-var\)\s +\(\(\w\|\s_\)+\)" + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face))))) + +(slime-def-connection-var slime-connection-number nil + "Serial number of a connection. +Bound in the connection's process-buffer.") + +(slime-def-connection-var slime-lisp-features '() + "The symbol-names of Lisp's *FEATURES*. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-lisp-package + "COMMON-LISP-USER" + "The current package name of the Superior lisp. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-lisp-package-prompt-string + "CL-USER" + "The current package name of the Superior lisp. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-pid nil + "The process id of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-type nil + "The implementation type of the Lisp process.") + +(slime-def-connection-var slime-lisp-implementation-version nil + "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-inferior-process nil + "The inferior process for the connection if any.") + +(slime-def-connection-var slime-communication-style nil + "The communication style.") + +(slime-def-connection-var slime-machine-instance nil + "The name of the (remote) machine running the Lisp process.") + +;;;;; Connection setup + +(defvar slime-connection-counter 0 + "The number of SLIME connections made. For generating serial numbers.") + +;;; Interface +(defun slime-setup-connection (process) + "Make a connection out of PROCESS." + (let ((slime-dispatching-connection process)) + (slime-init-connection-state process) + (slime-select-connection process) + process)) + +(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. + (when (equal slime-net-processes (list proc)) + (setq slime-connection-counter 0)) + (slime-with-connection-buffer () + (setq slime-buffer-connection proc)) + (setf (slime-connection-number proc) (incf slime-connection-counter)) + ;; 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) + (with-lexical-bindings (proc) + (lambda (info) + (slime-set-connection-info proc info))))) + +(defun slime-set-connection-info (connection info) + "Initialize CONNECTION with INFO received from Lisp." + (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 + (let ((args (when-let (p (slime-inferior-process)) + (slime-inferior-lisp-args p)))) + (when-let (name (plist-get args ':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) + (when-let (fun (plist-get args ':init-function)) + (funcall fun))) + (message "Connected. %s" (slime-random-words-of-encouragement)))) + +(defun slime-generate-connection-name (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-connection-name :test #'equal) + finally (return name))) + +(defun slime-connection-close-hook (process) + (when (eq process slime-default-connection) + (when slime-net-processes + (slime-select-connection (car slime-net-processes)) + (message "Default connection closed; switched to #%S (%S)" + (slime-connection-number) + (slime-connection-name))))) + +(add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook) + +;;;;; Commands on connections + +(defun slime-disconnect () + "Disconnect all connections." + (interactive) + (mapc #'slime-net-close slime-net-processes)) + +(defun slime-make-default-connection () + "Make the current connection the default connection." + (interactive) + (slime-select-connection (slime-connection)) + (message "Connection #%S (%s) now default SLIME connection." + (slime-connection-number) + (slime-connection-name))) + +(defun slime-choose-connection () + "Return an established connection chosen by the user." + (let ((default (slime-connection-name))) + (slime-find-connection-by-name + (completing-read (format "Connection name (default %s): " default) + (slime-bogus-completion-alist + (mapcar #'slime-connection-name slime-net-processes)) + nil + t + nil + nil + default)))) + +(defun slime-find-connection-by-name (name) + (find name slime-net-processes + :test #'string= :key #'slime-connection-name)) + +(defun slime-connection-port (connection) + "Return the remote port number of CONNECTION." + (if (featurep 'xemacs) + (car (process-id connection)) + (cadr (process-contact connection)))) + +(defun slime-process (&optional connection) + "Return the Lisp process for CONNECTION (default `slime-connection'). +Can return nil if there's no process object for the connection." + (let ((proc (slime-inferior-process connection))) + (if (and proc + (memq (process-status proc) '(run stop))) + proc))) + +;; Non-macro version to keep the file byte-compilable. +(defun slime-set-inferior-process (connection process) + (setf (slime-inferior-process connection) process)) + +(defun slime-use-sigint-for-interrupt (&optional connection) + (let ((c (or connection (slime-connection)))) + (ecase (slime-communication-style c) + ((:fd-handler nil) t) + ((:spawn :sigio) nil)))) + +(defvar slime-inhibit-pipelining t + "*If true, don't send background requests if Lisp is already busy.") + +(defun slime-background-activities-enabled-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)))) + + +;;;; Communication protocol + +;;;;; Emacs Lisp programming interface +;;; +;;; The programming interface for writing Emacs commands is based on +;;; remote procedure calls (RPCs). The basic operation is to ask Lisp +;;; to apply a named Lisp function to some arguments, then to do +;;; something with the result. +;;; +;;; Requests can be either synchronous (blocking) or asynchronous +;;; (with the result passed to a callback/continuation function). If +;;; an error occurs during the request then the debugger is entered +;;; before the result arrives -- for synchronous evaluations this +;;; requires a recursive edit. +;;; +;;; You should use asynchronous evaluations (`slime-eval-async') for +;;; most things. Reserve synchronous evaluations (`slime-eval') for +;;; the cases where blocking Emacs is really appropriate (like +;;; completion) and that shouldn't trigger errors (e.g. not evaluate +;;; user-entered code). +;;; +;;; We have the concept of the "current Lisp package". RPC requests +;;; always say what package the user is making them from and the Lisp +;;; side binds that package to *BUFFER-PACKAGE* to use as it sees +;;; fit. The current package is defined as the buffer-local value of +;;; `slime-buffer-package' if set, and otherwise the package named by +;;; the nearest IN-PACKAGE as found by text search (first backwards, +;;; then forwards). +;;; +;;; Similarly we have the concept of the current thread, i.e. which +;;; thread in the Lisp process should handle the request. The current +;;; thread is determined solely by the buffer-local value of +;;; `slime-current-thread'. This is usually bound to t meaning "no +;;; particular thread", but can also be used to nominate a specific +;;; thread. The REPL and the debugger both use this feature to deal +;;; with specific threads. + +(make-variable-buffer-local + (defvar slime-current-thread t + "The id of the current thread on the Lisp side. +t means the "current" thread; +:repl-thread the thread that executes REPL requests; +fixnum a specific thread.")) + +(make-variable-buffer-local + (defvar slime-buffer-package nil + "The Lisp package associated with the current buffer. +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 if +;;; you need to, but the others are usually more convenient. + +(defmacro* slime-rex ((&rest saved-vars) + (sexp &optional + (package '(slime-current-package)) + (thread 'slime-current-thread)) + &rest continuations) + "(slime-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...) + +Remote EXecute SEXP. + +VARs are a list of saved variables visible in the other forms. Each +VAR is either a symbol or a list (VAR INIT-VALUE). + +SEXP is evaluated and the princed version is sent to Lisp. + +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 of SEXP is +dispatched on CLAUSES. The result is either a sexp of the +form (:ok VALUE) or (:abort). CLAUSES is executed +asynchronously. + +Note: don't use backquote syntax for SEXP, because Emacs20 cannot +deal with that." + (let ((result (gensym))) + `(lexical-let ,(loop for var in saved-vars + collect (etypecase var + (symbol (list var var)) + (cons var))) + (slime-dispatch-event + (list :emacs-rex ,sexp ,package ,thread + (lambda (,result) + (destructure-case ,result + ,@continuations))))))) + +(put 'slime-rex 'lisp-indent-function 2) + +;;; Interface +(defun slime-current-package () + "Return the Common Lisp package in the current context. +If `slime-buffer-package' has a value then return that, otherwise +search for and read an `in-package' form. + +The REPL buffer is a special case: it's package is `slime-lisp-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 '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." + (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 (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 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. + +(defvar slime-stack-eval-tags nil + "List of stack-tags of continuations waiting on the stack.") + +(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 (format "slime-result-%d-" + (1+ (slime-continuation-counter))))) + (slime-stack-eval-tags (cons tag slime-stack-eval-tags))) + (apply + #'funcall + (catch tag + (slime-rex (tag sexp) + (sexp package) + ((:ok value) + (unless (member tag slime-stack-eval-tags) + (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.")))) + (let ((debug-on-quit t) + (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." + (slime-rex (cont (buffer (current-buffer))) + (sexp (or package (slime-current-package))) + ((:ok result) + (when cont + (set-buffer buffer) + (funcall cont result))) + ((:abort) + (message "Evaluation aborted.")))) + +;;; These functions can be handy too: + +(defun slime-connected-p () + "Return true if the Swank connection is open." + (not (null slime-net-processes))) + +(defun slime-check-connected () + "Signal an error if we are not connected to Lisp." + (unless (slime-connected-p) + (error "Not connected. Use `%s' to start a Lisp." + (substitute-command-keys "\[slime]")))) + +(defun slime-busy-p () + "True if Lisp has outstanding requests. +Debugged requests are ignored." + (let ((debugged (sldb-debugged-continuations (slime-connection)))) + (remove-if (lambda (id) + (memq id debugged)) + (slime-rex-continuations) + :key #'car))) + +;; dummy defvar for compiler +(defvar slime-repl-read-mode) + +(defun slime-reading-p () + "True if Lisp is currently reading input from the REPL." + (with-current-buffer (slime-output-buffer) + slime-repl-read-mode)) + +(defun slime-sync () + "Block until the most recent request has finished." + (when (slime-rex-continuations) + (let ((tag (caar (slime-rex-continuations)))) + (while (find tag (slime-rex-continuations) :key #'car) + (slime-accept-process-output nil 0.1))))) + +(defun slime-ping () + "Check that communication works." + (interactive) + (message "%s" (slime-eval "PONG"))) + +;;;;; Protocol event handler (the guts) +;;; +;;; This is the protocol in all its glory. The input to this function +;;; is a protocol event that either originates within Emacs or arrived +;;; over the network from Lisp. +;;; +;;; Each event is a list beginning with a keyword and followed by +;;; arguments. The keyword identifies the type of event. Events +;;; originating from Emacs have names starting with :emacs- and events +;;; from Lisp don't. + +(slime-def-connection-var slime-rex-continuations '() + "List of (ID . FUNCTION) continuations waiting for RPC results.") + +(slime-def-connection-var slime-continuation-counter 0 + "Continuation serial number counter.") + +(defvar slime-event-hooks) + +(defun slime-dispatch-event (event &optional process) + (let ((slime-dispatching-connection (or process (slime-connection)))) + (or (run-hook-with-args-until-success 'slime-event-hooks event) + (destructure-case event + ((:write-string output &optional target) + (slime-write-string output target)) + ((:emacs-rex form package thread continuation) + (slime-set-state "|eval...") + (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) + (message "; pipelined request... %S" form)) + (let ((id (incf (slime-continuation-counter)))) + (push (cons id continuation) (slime-rex-continuations)) + (slime-send `(:emacs-rex ,form ,package ,thread ,id)))) + ((:return value id) + (let ((rec (assq id (slime-rex-continuations)))) + (cond (rec (setf (slime-rex-continuations) + (remove rec (slime-rex-continuations))) + (when (null (slime-rex-continuations)) + (slime-set-state "")) + (funcall (cdr rec) value)) + (t + (error "Unexpected reply: %S %S" id value))))) + ((:debug-activate thread level) + (assert thread) + (sldb-activate thread level)) + ((:debug thread level condition restarts frames conts) + (assert thread) + (sldb-setup thread level condition restarts frames conts)) + ((:debug-return thread level stepping) + (assert thread) + (sldb-exit thread level stepping)) + ((:emacs-interrupt thread) + (slime-send `(:emacs-interrupt ,thread))) + ((:read-string thread tag) + (assert thread) + (slime-repl-read-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)) + ((:emacs-return-string thread tag string) + (slime-send `(:emacs-return-string ,thread ,tag ,string))) + ;; + ((:new-package package prompt-string) + (setf (slime-lisp-package) package) + (setf (slime-lisp-package-prompt-string) prompt-string)) + ((:new-features features) + (setf (slime-lisp-features) features)) + ((:indentation-update info) + (slime-handle-indentation-update info)) + ((:open-dedicated-output-stream port) + (slime-open-stream-to-lisp port)) + ((:eval-no-wait fun args) + (apply (intern fun) args)) + ((:eval thread tag form-string) + (slime-check-eval-in-emacs-enabled) + (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)) + ((:inspect what) + (slime-open-inspector what)) + ((:background-message message) + (slime-background-message "%s" message)) + ((:debug-condition thread message) + (assert thread) + (message "%s" message)))))) + +(defun slime-send (sexp) + "Send SEXP directly over the wire on the current connection." + (slime-net-send sexp (slime-connection))) + +(defun slime-reset () + "Clear all pending continuations." + (interactive) + (setf (slime-rex-continuations) '()) + (mapc #'kill-buffer (sldb-buffers))) + +(defun slime-send-sigint () + (interactive) + (signal-process (slime-pid) 'SIGINT)) + +;;;;; Event logging to *slime-events* +;;; +;;; The *slime-events* buffer logs all protocol messages for debugging +;;; purposes. Optionally you can enable outline-mode in that buffer, +;;; which is convenient but slows things down significantly. + +(defvar slime-log-events t + "*Log protocol events to the *slime-events* buffer.") + +(defvar slime-outline-mode-in-events-buffer nil + "*Non-nil means use outline-mode in *slime-events*.") + +(defvar slime-event-buffer-name "*slime-events*" + "The name of the slime event buffer.") + +(defun slime-log-event (event) + "Record the fact that EVENT occurred." + (when slime-log-events + (with-current-buffer (slime-events-buffer) + ;; trim? + (when (> (buffer-size) 100000) + (goto-char (/ (buffer-size) 2)) + (re-search-forward "^(" nil t) + (delete-region (point-min) (point))) + (goto-char (point-max)) + (save-excursion + (slime-pprint-event event (current-buffer))) + (when (and (boundp 'outline-minor-mode) + outline-minor-mode) + (hide-entry)) + (goto-char (point-max))))) + +(defun slime-pprint-event (event buffer) + "Pretty print EVENT in BUFFER with limited depth and width." + (let ((print-length 20) + (print-level 6) + (pp-escape-newlines t)) + (pp event buffer))) + +(defun slime-events-buffer () + (or (get-buffer slime-event-buffer-name) + (let ((buffer (get-buffer-create slime-event-buffer-name))) + (with-current-buffer buffer + (set (make-local-variable 'outline-regexp) "^(") + (set (make-local-variable 'comment-start) ";") + (set (make-local-variable 'comment-end) "") + (when slime-outline-mode-in-events-buffer + (outline-minor-mode))) + buffer))) + + +;;;; Stream output + +(slime-def-connection-var slime-connection-output-buffer nil + "The buffer for the REPL. May be nil or a dead buffer.") + +(make-variable-buffer-local + (defvar slime-output-start nil + "Marker for the start of the output for the evaluation.")) + +(make-variable-buffer-local + (defvar slime-output-end nil + "Marker for end of output. New output is inserted at this mark.")) + +;; dummy definitions for the compiler +(defvar slime-repl-package-stack) +(defvar slime-repl-directory-stack) +(defvar slime-repl-input-start-mark) +(defvar slime-repl-prompt-start-mark) + + +(defun slime-output-buffer (&optional noprompt) + "Return the output buffer, create it if necessary." + (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)) + (current-buffer))))))) + +(defvar slime-repl-banner-function 'slime-repl-insert-banner) + +(defun slime-repl-update-banner () + (funcall slime-repl-banner-function) + (goto-char (point-max)) + (slime-mark-output-start) + (slime-mark-input-start) + (slime-repl-insert-prompt) + (pop-to-buffer (current-buffer))) + +(defun slime-repl-insert-banner () + (when (zerop (buffer-size)) + (let ((welcome (concat "; SLIME " (or (slime-changelog-date) + "- ChangeLog file not found")))) + (insert welcome)))) + +(defun slime-init-output-buffer (connection) + (with-current-buffer (slime-output-buffer t) + (setq slime-buffer-connection connection + slime-repl-directory-stack '() + slime-repl-package-stack '()) + (slime-repl-update-banner))) + +(defvar slime-show-last-output-function + 'slime-maybe-display-output-buffer + "*This function is called when a evaluation request is finished. +It is called in the slime-output buffer and receives the region of the +output as arguments.") + +(defun slime-show-last-output-region (start end) + (when (< start end) + (slime-display-buffer-region (current-buffer) (1- start) + slime-repl-input-start-mark))) + +(defun slime-maybe-display-output-buffer (start end) + (when (and (< start end) + (not (get-buffer-window (current-buffer) t))) + (display-buffer (current-buffer))) + (when (eobp) + (slime-repl-show-maximum-output t))) + +(defun slime-show-last-output () + "Show the output from the last Lisp evaluation." + (with-current-buffer (slime-output-buffer) + (let ((start slime-output-start) + (end slime-output-end)) + (funcall slime-show-last-output-function start end)))) + +(defun slime-display-output-buffer () + "Display the output buffer and scroll to bottom." + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (unless (get-buffer-window (current-buffer) t) + (display-buffer (current-buffer) t)) + (slime-repl-show-maximum-output))) + +(defmacro slime-with-output-end-mark (&rest body) + "Execute BODY at `slime-output-end'. + +If point is initially at `slime-output-end' and the buffer is visible +update window-point afterwards. If point is initially not at +`slime-output-end, execute body inside a `save-excursion' block." + `(let ((body.. (lambda () ,@body)) + (updatep.. (and (eobp) (pos-visible-in-window-p)))) + (cond ((= (point) slime-output-end) + (let ((start.. (point))) + (funcall body..) + (set-marker slime-output-end (point)) + (when (= start.. slime-repl-input-start-mark) + (set-marker slime-repl-input-start-mark (point))))) + (t + (save-excursion + (goto-char slime-output-end) + (funcall body..)))) + (when updatep.. + (slime-repl-show-maximum-output + (> (- slime-output-end slime-output-start) 1000))))) + +(defun slime-output-filter (process string) + (with-current-buffer (process-buffer process) + (when (and (plusp (length string)) + (eq (process-status slime-buffer-connection) 'open)) + (slime-write-string string)))) + +(defvar slime-open-stream-hooks) + +(defun slime-open-stream-to-lisp (port) + (let ((stream (open-network-stream "*lisp-output-stream*" + (slime-with-connection-buffer () + (current-buffer)) + slime-lisp-host port))) + (slime-set-query-on-exit-flag stream) + (set-process-filter stream 'slime-output-filter) + (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)) + (run-hook-with-args 'slime-open-stream-hooks stream) + stream)) + +(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))))) + +(defvar slime-write-string-function 'slime-repl-write-string) + +(defun slime-write-string (string &optional target) + "Insert STRING in the REPL buffer or some other TARGET. +If TARGET is nil, insert STRING as regular process +output. If TARGET is :repl-result, insert STRING as the result of the +evaluation. Other values of TARGET map to an Emacs marker via the +hashtable `slime-output-target-to-marker'; output is inserted at this marker." + (funcall slime-write-string-function string target)) + +(defun slime-repl-write-string (string &optional target) + (case target + ((nil) (slime-repl-emit string)) + (:repl-result (slime-repl-emit-result string)) + (t (slime-emit-string string target)))) + +(defun slime-repl-emit (string) + ;; insert the string STRING in the output buffer + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (slime-insert-propertized '(face slime-repl-output-face + rear-nonsticky (face)) + string) + (set-marker slime-output-end (point)) + (when (and (= (point) slime-repl-prompt-start-mark) + (not (bolp))) + (insert "\n") + (set-marker slime-output-end (1- (point)))) + (when (< slime-repl-input-start-mark (point)) + (set-marker slime-repl-input-start-mark (point)))))) + +(defun slime-repl-emit-result (string) + ;; insert STRING and mark it as evaluation result + (with-current-buffer (slime-output-buffer) + (goto-char slime-repl-input-start-mark) + (slime-insert-propertized `(face slime-repl-result-face + rear-nonsticky (face)) + string) + (set-marker slime-repl-input-start-mark (point)))) + +(defvar slime-last-output-target-id 0 + "The last integer we used as a TARGET id.") + +(defvar slime-output-target-to-marker + (make-hash-table) + "Map from TARGET ids to Emacs markers. +The markers indicate where output should be inserted.") + +(defun slime-output-target-marker (target) + "Return the marker where output for TARGET should be inserted." + (case target + ((nil) + (with-current-buffer (slime-output-buffer) + slime-output-end)) + (:repl-result + (with-current-buffer (slime-output-buffer) + slime-repl-input-start-mark)) + (t + (gethash target slime-output-target-to-marker)))) + +(defun slime-emit-string (string target) + "Insert STRING at target TARGET. +See `slime-output-target-to-marker'." + (let* ((marker (slime-output-target-marker target)) + (buffer (and marker (marker-buffer marker)))) + (when buffer + (with-current-buffer buffer + (save-excursion + ;; Insert STRING at MARKER, then move MARKER behind + ;; the insertion. + (goto-char marker) + (insert-before-markers string) + (set-marker marker (point))))))) + +(defun slime-switch-to-output-buffer (&optional connection) + "Select the output buffer, preferably in a different window." + (interactive (list (if prefix-arg (slime-choose-connection)))) + (let ((slime-dispatching-connection (or connection + slime-dispatching-connection))) + (set-buffer (slime-output-buffer)) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t)) + (goto-char (point-max)))) + + +;;;; REPL +;; +;; The REPL uses some markers to separate input from output. The +;; usual configuration is as follows: +;; +;; ... output ... ... result ... prompt> ... input ... +;; ^ ^ ^ ^ ^ +;; output-start output-end prompt-start input-start input-end +;; +;; output-start and input-start are right inserting markers; +;; output-end and input-end left inserting. +;; +;; We maintain the following invariant: +;; +;; output-start <= output-end <= input-start <= input-end. +;; +;; This invariant is important, because we must be prepared for +;; asynchronous output and asynchronous reads. ("Asynchronous" means, +;; triggered by Lisp and not by Emacs.) +;; +;; All output is inserted at the output-end marker. Some care must be +;; taken when output-end and input-start are at the same position: if +;; we blindly insert at that point, we break the invariant stated +;; above, because the output-end marker is left inserting. The macro +;; `slime-with-output-end-mark' handles this complication by moving +;; the input-start marker to an appropriate place. The macro also +;; updates window-point if necessary, and tries to keep the prompt in +;; the first column by inserting a newline. +;; +;; A "synchronous" evaluation request proceeds as follows: the user +;; inserts some text between input-start and input-end and then hits +;; return. We send the text between the input markers to Lisp, move +;; the output and input makers to the line after the input and wait. +;; When we receive the result, we insert it together with a prompt +;; between the output-end and input-start mark. +;; `slime-repl-insert-prompt' does this. +;; +;; It is possible that some output for such an evaluation request +;; arrives after the result. This output is inserted before the +;; result (and before the prompt). Output that doesn't belong the +;; evaluation request should not be inserted before the result, but +;; immediately before the prompt. To achieve this, we move the +;; output-end mark to prompt-start after a short delay (by starting a +;; timer in `slime-repl-insert-prompt'). In summary: synchronous +;; output should go before the result, asynchronous before the prompt. +;; +;; If we are in "reading" state, e.g., during a call to Y-OR-N-P, +;; there is no prompt between output-end and input-start. +;; + +;; Small helper. +(defun slime-make-variables-buffer-local (&rest variables) + (mapcar #'make-variable-buffer-local variables)) + +(slime-make-variables-buffer-local + (defvar slime-repl-package-stack nil + "The stack of packages visited in this repl.") + + (defvar slime-repl-directory-stack nil + "The stack of default directories associated with this repl.") + + (defvar slime-repl-prompt-start-mark) + (defvar slime-repl-input-start-mark) + (defvar slime-repl-input-end-mark) + (defvar slime-repl-last-input-start-mark) + (defvar slime-repl-old-input-counter 0 + "Counter used to generate unique `slime-repl-old-input' properties. +This property value must be unique to avoid having adjacent inputs be +joined together.")) + +(defun slime-reset-repl-markers () + (dolist (markname '(slime-output-start + slime-output-end + slime-repl-prompt-start-mark + slime-repl-input-start-mark + slime-repl-input-end-mark + slime-repl-last-input-start-mark)) + (set markname (make-marker)) + (set-marker (symbol-value markname) (point))) + ;; (set-marker-insertion-type slime-output-end t) + (set-marker-insertion-type slime-repl-input-end-mark t) + (set-marker-insertion-type slime-repl-prompt-start-mark t)) + +;;;;; REPL mode setup + +(defvar slime-repl-mode-map) + +(setq slime-repl-mode-map (make-sparse-keymap)) +(set-keymap-parent slime-repl-mode-map lisp-mode-map) + +(dolist (spec slime-keys) + (destructuring-bind (key command &key inferior prefixed + &allow-other-keys) spec + (when inferior + (let ((key (if prefixed (concat slime-prefix-key key) key))) + (define-key slime-repl-mode-map key command))))) + +(slime-define-keys slime-repl-mode-map + ("\C-m" 'slime-repl-return) + ("\C-j" 'slime-repl-newline-and-indent) + ("\C-\M-m" 'slime-repl-closing-return) + ([(control return)] 'slime-repl-closing-return) + ("\C-a" 'slime-repl-bol) + ([home] 'slime-repl-bol) + ("\C-e" 'slime-repl-eol) + ("\M-p" 'slime-repl-previous-input) + ((kbd "C-<up>") 'slime-repl-backward-input) + ("\M-n" 'slime-repl-next-input) + ((kbd "C-<down>") 'slime-repl-forward-input) + ("\M-r" 'slime-repl-previous-matching-input) + ("\M-s" 'slime-repl-next-matching-input) + ("\C-c\C-c" 'slime-interrupt) + ("\C-c\C-b" 'slime-interrupt) + ("\C-c:" 'slime-interactive-eval) + ("\C-c\C-e" 'slime-interactive-eval) + ("\C-cE" 'slime-edit-value) + ;("\t" 'slime-complete-symbol) + ("\t" 'slime-indent-and-complete-symbol) + (" " 'slime-space) + ("\C-c\C-d" slime-doc-map) + ("\C-c\C-w" slime-who-map) + ("\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) + ("\C-c\C-l" 'slime-load-file) + ("\C-c\C-k" 'slime-compile-and-load-file) + ("\C-c\C-z" 'slime-nop)) + +(defun slime-repl-mode () + "Major mode for interacting with a superior Lisp. +\{slime-repl-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'slime-repl-mode) + (use-local-map slime-repl-mode-map) + (lisp-mode-variables t) + (set (make-local-variable 'lisp-indent-function) + 'common-lisp-indent-function) + (setq font-lock-defaults nil) + (setq mode-name "REPL") + (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) + ;; At the REPL, we define beginning-of-defun and end-of-defun to be + ;; the start of the previous prompt or next prompt respectively. + ;; Notice the interplay with SLIME-REPL-BEGINNING-OF-DEFUN. + (set (make-local-variable 'beginning-of-defun-function) + 'slime-repl-mode-beginning-of-defun) + (set (make-local-variable 'end-of-defun-function) + 'slime-repl-mode-end-of-defun) + (run-hooks 'slime-repl-mode-hook)) + +(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*" (slime-connection-name connection)))) + +(defun slime-repl () + (interactive) + (slime-switch-to-output-buffer)) + +(defun slime-repl-mode-beginning-of-defun () + (slime-repl-previous-prompt) + t) + +(defun slime-repl-mode-end-of-defun () + (slime-repl-next-prompt) + t) + +(defun slime-repl-send-string (string &optional command-string) + (cond (slime-repl-read-mode + (slime-repl-return-string string)) + (t (slime-repl-eval-string string)))) + +(defun slime-repl-eval-string (string) + (slime-rex () + ((list 'swank:listener-eval string) (slime-lisp-package)) + ((:ok result) + (slime-repl-insert-result result)) + ((:abort) + (slime-repl-show-abort)))) + +(defun slime-repl-insert-result (result) + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (when result + (destructure-case result + ((:values &rest strings) + (unless (bolp) (insert "\n")) + (cond ((null strings) + (insert "; No value\n")) + (t + (dolist (string strings) + (slime-propertize-region `(face slime-repl-result-face) + (insert string)) + (insert "\n"))))))) + (slime-repl-insert-prompt))) + +(defun slime-repl-show-abort () + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (unless (bolp) (insert-before-markers "\n")) + (insert-before-markers "; Evaluation aborted.\n")) + (slime-repl-insert-prompt))) + +(defun slime-repl-insert-prompt () + "Goto to point max, and insert the prompt." + (goto-char slime-repl-input-start-mark) + (assert (= slime-repl-input-end-mark (point-max))) + (unless (bolp) (insert "\n")) + (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 + slime-repl-prompt t + ;; emacs stuff + rear-nonsticky (slime-repl-prompt read-only face intangible) + ;; xemacs stuff + start-open t end-open t) + (insert-before-markers prompt)) + (slime-mark-input-start) + (set-marker slime-repl-input-end-mark (point-max)) + (set-marker slime-repl-prompt-start-mark prompt-start) + (goto-char slime-repl-prompt-start-mark) + (slime-mark-output-start) + (goto-char (point-max))) + (slime-repl-show-maximum-output)) + +(defun slime-repl-show-maximum-output (&optional force) + "Put the end of the buffer at the bottom of the window." + (assert (eobp)) + (let ((win (get-buffer-window (current-buffer)))) + (when win + (with-selected-window win + (recenter -1))))) + +(defvar slime-repl-current-input-hooks) + +(defun slime-repl-current-input (&optional until-point-p) + "Return the current input as string. +The input is the region from after the last prompt to the end of +buffer." + (or (run-hook-with-args-until-success 'slime-repl-current-input-hooks + until-point-p) + (buffer-substring-no-properties + slime-repl-input-start-mark + (if (and until-point-p (<= (point) slime-repl-input-end-mark)) + (point) + slime-repl-input-end-mark)))) + +(defun slime-property-position (text-property &optional object) + "Return the first position of TEXT-PROPERTY, or nil." + (if (get-text-property 0 text-property object) + 0 + (next-single-property-change 0 text-property object))) + +(defun slime-mark-input-start () + (set-marker slime-repl-last-input-start-mark + (marker-position slime-repl-input-start-mark)) + (set-marker slime-repl-input-start-mark (point) (current-buffer)) + (set-marker slime-repl-input-end-mark (point) (current-buffer))) + +(defun slime-mark-output-start (&optional position) + (let ((position (or position (point)))) + (set-marker slime-output-start position) + (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)))) + +(defun slime-repl-bol () + "Go to the beginning of line or the prompt." + (interactive) + (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 () + "Go to the end of line or the prompt." + (interactive) + (if (and (<= (point) slime-repl-input-end-mark) + (slime-same-line-p (point) slime-repl-input-end-mark)) + (goto-char slime-repl-input-end-mark) + (end-of-line 1)) + (slime-preserve-zmacs-region)) + +(defun slime-preserve-zmacs-region () + "In XEmacs, ensure that the zmacs-region stays active after this command." + (when (boundp 'zmacs-region-stays) + (set 'zmacs-region-stays t))) + +(defun slime-repl-in-input-area-p () + (and (<= slime-repl-input-start-mark (point)) + (<= (point) slime-repl-input-end-mark))) + +(defun slime-repl-at-prompt-start-p () + ;; This will not work on non-current prompts. + (= (point) slime-repl-input-start-mark)) + +(defun slime-repl-beginning-of-defun () + "Move to beginning of defun." + (interactive) + ;; We call BEGINNING-OF-DEFUN if we're at the start of a prompt + ;; already, to trigger SLIME-REPL-MODE-BEGINNING-OF-DEFUN by means + ;; of the locally bound BEGINNING-OF-DEFUN-FUNCTION, in order to + ;; jump to the start of the previous prompt. + (if (and (not (slime-repl-at-prompt-start-p)) + (slime-repl-in-input-area-p)) + (goto-char slime-repl-input-start-mark) + (beginning-of-defun)) + t) + +(defun slime-repl-end-of-defun () + "Move to next of defun." + (interactive) + ;; C.f. SLIME-REPL-BEGINNING-OF-DEFUN. + (if (and (not (= (point) slime-repl-input-end-mark)) + (slime-repl-in-input-area-p)) + (goto-char slime-repl-input-end-mark) + (end-of-defun)) + t) + +;; FIXME: Shouldn't this be (= (point) slime-repl-input-end-mark)? +(defun slime-repl-at-prompt-end-p () + (and (get-char-property (max 1 (1- (point))) 'slime-repl-prompt) + (not (get-char-property (point) 'slime-repl-prompt)))) + +(defun slime-repl-find-prompt (move) + (let ((origin (point))) + (loop (funcall move) + (when (or (slime-repl-at-prompt-end-p) (bobp) (eobp)) + (return))) + (unless (slime-repl-at-prompt-end-p) + (goto-char origin)))) + +(defun slime-search-property-change-fn (prop &optional backward) + (with-lexical-bindings (prop) + (if backward + (lambda () + (goto-char + (previous-single-char-property-change (point) prop))) + (lambda () + (goto-char + (next-single-char-property-change (point) prop)))))) + +(defun slime-repl-previous-prompt () + "Move backward to the previous prompt." + (interactive) + (slime-repl-find-prompt + (slime-search-property-change-fn 'slime-repl-prompt t))) + +(defun slime-repl-next-prompt () + "Move forward to the next prompt." + (interactive) + (slime-repl-find-prompt + (slime-search-property-change-fn 'slime-repl-prompt))) + +(defvar slime-repl-return-hooks) + +(defun slime-repl-return (&optional end-of-input) + "Evaluate the current input string, or insert a newline. +Send the current input ony if a whole expression has been entered, +i.e. the parenthesis are matched. + +With prefix argument send the input even if the parenthesis are not +balanced." + (interactive "P") + (slime-check-connected) + (assert (<= (point) slime-repl-input-end-mark)) + (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) + (slime-repl-recenter-if-needed)) + ((run-hook-with-args-until-success 'slime-repl-return-hooks)) + ((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)) + (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) + (let ((end (point))) ; end of input, without the newline + (slime-repl-add-to-input-history + (buffer-substring slime-repl-input-start-mark end)) + (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))) + (let ((input (slime-repl-current-input))) + (goto-char slime-repl-input-end-mark) + (slime-mark-input-start) + (slime-mark-output-start) + (slime-repl-send-string input))) + +(defun slime-repl-grab-old-input (replace) + "Resend the old REPL input at point. +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) + (let ((old-input (buffer-substring beg end)) ;;preserve + ;;properties, they will be removed later + (offset (- (point) beg))) + ;; Append the old input or replace the current input + (cond (replace (goto-char slime-repl-input-start-mark)) + (t (goto-char slime-repl-input-end-mark) + (unless (eq (char-before) ?\ ) + (insert " ")))) + (delete-region (point) slime-repl-input-end-mark) + (save-excursion (insert old-input)) + (forward-char offset)))) + +(defun slime-property-bounds (prop) + "Return two the positions of the previous and next changes to PROP. +PROP is the name of a text property." + (let* ((beg (save-excursion + ;; previous-single-char-property-change searches for a + ;; property change from the previous character, but we + ;; want to look for a change from the point. We step + ;; 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) 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) prop) + (progn (goto-char (next-single-char-property-change + (point) prop)) + (skip-chars-backward "\n \t\r" beg) + (point)) + (point))))) + (values beg end))) + +(defun slime-repl-closing-return () + "Evaluate the current input string after closing all open lists." + (interactive) + (goto-char (point-max)) + (save-restriction + (narrow-to-region slime-repl-input-start-mark (point)) + (while (ignore-errors (save-excursion (backward-up-list 1)) t) + (insert ")"))) + (slime-repl-return)) + +(defun slime-repl-newline-and-indent () + "Insert a newline, then indent the next line. +Restrict the buffer from the prompt for indentation, to avoid being +confused by strange characters (like unmatched quotes) appearing +earlier in the buffer." + (interactive) + (save-restriction + (narrow-to-region slime-repl-prompt-start-mark (point-max)) + (insert "\n") + (lisp-indent-line))) + +(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 the prompt to point." + (interactive) + (cond ((< (marker-position slime-repl-input-start-mark) (point)) + (kill-region slime-repl-input-start-mark (point))) + ((= (point) (marker-position slime-repl-input-start-mark)) + (slime-repl-delete-current-input)))) + +(defun slime-repl-replace-input (string) + (slime-repl-delete-current-input) + (insert-and-inherit string)) + +(defun slime-repl-input-line-beginning-position () + (save-excursion + (goto-char slime-repl-input-start-mark) + (line-beginning-position))) + +(defvar slime-repl-clear-buffer-hook) + +(defun slime-repl-clear-buffer () + "Delete the output generated by the Lisp process." + (interactive) + (set-marker slime-repl-last-input-start-mark nil) + (let ((inhibit-read-only t)) + (delete-region (point-min) (slime-repl-input-line-beginning-position)) + (goto-char slime-repl-input-start-mark)) + (run-hooks 'slime-repl-clear-buffer-hook)) + +(defun slime-repl-clear-output () + "Delete the output inserted since the last input." + (interactive) + (let ((start (save-excursion + (slime-repl-previous-prompt) + (ignore-errors (forward-sexp)) + (forward-line) + (point))) + (end (1- (slime-repl-input-line-beginning-position)))) + (when (< start end) + (let ((inhibit-read-only t)) + (delete-region start end) + (save-excursion + (goto-char start) + (insert ";;; output flushed")))))) + +(defun slime-indent-and-complete-symbol () + "Indent the current line and perform 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-complete-symbol)) + ((memq (char-before) '(?\t ?\ )) + (slime-echo-arglist)))))) + +(defun slime-repl-set-package (package) + "Set the package of the REPL buffer to PACKAGE." + (interactive (list (slime-read-package-name "Package: " + (slime-find-buffer-package)))) + (with-current-buffer (slime-output-buffer) + (let ((unfinished-input (slime-repl-current-input))) + (destructuring-bind (name prompt-string) + (slime-eval `(swank:set-package ,package)) + (setf (slime-lisp-package) name) + (setf (slime-lisp-package-prompt-string) prompt-string) + (slime-repl-insert-prompt) + (insert unfinished-input))))) + + +;;;;; History + +(defcustom slime-repl-wrap-history nil + "*T to wrap history around when the end is reached." + :type 'boolean + :group 'slime-repl) + +(make-variable-buffer-local + (defvar slime-repl-input-history '() + "History list of strings read from the REPL buffer.")) + +(defun slime-repl-add-to-input-history (string) + "Add STRING to the input history. +Empty strings and duplicates are ignored." + (unless (or (equal string "") + (equal string (car slime-repl-input-history))) + (push string slime-repl-input-history))) + +;; These two vars contain the state of the last history search. We +;; only use them if `last-command' was 'slime-repl-history-replace, +;; otherwise we reinitialize them. + +(defvar slime-repl-input-history-position -1 + "Newer items have smaller indices.") + +(defvar slime-repl-history-pattern nil + "The regexp most recently used for finding input history.") + +(defun slime-repl-history-replace (direction &optional regexp delete-at-end-p) + "Replace the current input with the next line in DIRECTION. +DIRECTION is 'forward' or 'backward' (in the history list). +If REGEXP is non-nil, only lines matching REGEXP are considered. +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* ((min-pos -1) + (max-pos (length slime-repl-input-history)) + (pos0 (cond ((slime-repl-history-search-in-progress-p) + slime-repl-input-history-position) + (t min-pos))) + (pos (slime-repl-position-in-history pos0 direction (or regexp ""))) + (msg nil)) + (cond ((and (< min-pos pos) (< pos max-pos)) + (slime-repl-replace-input (nth pos slime-repl-input-history)) + (setq msg (format "History item: %d" pos))) + ((not slime-repl-wrap-history) + (setq msg (cond ((= pos min-pos) "End of history") + ((= pos max-pos) "Beginning of history")))) + (slime-repl-wrap-history + (setq pos (if (= pos min-pos) max-pos min-pos)) + (setq msg "Wrapped history"))) + (when (or (<= pos min-pos) (<= max-pos pos)) + (when regexp + (setq msg (concat msg "; no matching item"))) + (when delete-at-end-p + (slime-repl-replace-input ""))) + ;;(message "%s [%d %d %s]" msg start-pos pos regexp) + (message "%s%s" msg (cond ((not regexp) "") + (t (format "; current regexp: %s" regexp)))) + (setq slime-repl-input-history-position pos) + (setq this-command 'slime-repl-history-replace))) + +(defun slime-repl-history-search-in-progress-p () + (eq last-command 'slime-repl-history-replace)) + +(defun slime-repl-terminate-history-search () + (setq last-command this-command)) + +(defun slime-repl-position-in-history (start-pos direction regexp) + "Return the position of the history item matching regexp. +Return -1 resp. the length of the history if no item matches" + ;; Loop through the history list looking for a matching line + (let* ((step (ecase direction + (forward -1) + (backward 1))) + (history slime-repl-input-history) + (len (length history))) + (loop for pos = (+ start-pos step) then (+ pos step) + if (< pos 0) return -1 + if (<= len pos) return len + if (string-match regexp (nth pos history)) return pos))) + +(defun slime-repl-previous-input () + "Cycle backwards through input history. +If the `last-command' was a history navigation command use the +same search pattern for this command. +Otherwise use the current input as search pattern." + (interactive) + (slime-repl-history-replace 'backward (slime-repl-history-pattern t) t)) + +(defun slime-repl-next-input () + "Cycle forwards through input history. +See `slime-repl-previous-input'." + (interactive) + (slime-repl-history-replace 'forward (slime-repl-history-pattern t) t)) + +(defun slime-repl-forward-input () + "Cycle forwards through input history." + (interactive) + (slime-repl-history-replace 'forward (slime-repl-history-pattern) t)) + +(defun slime-repl-backward-input () + "Cycle backwards through input history." + (interactive) + (slime-repl-history-replace 'backward (slime-repl-history-pattern) t)) + +(defun slime-repl-previous-matching-input (regexp) + (interactive "sPrevious element matching (regexp): ") + (slime-repl-terminate-history-search) + (slime-repl-history-replace 'backward regexp)) + +(defun slime-repl-next-matching-input (regexp) + (interactive "sNext element matching (regexp): ") + (slime-repl-terminate-history-search) + (slime-repl-history-replace 'forward regexp)) + +(defun slime-repl-history-pattern (&optional use-current-input) + "Return the regexp for the navigation commands." + (cond ((slime-repl-history-search-in-progress-p) + slime-repl-history-pattern) + (use-current-input + (let ((str (slime-repl-current-input))) + (cond ((string-match "^[ \n]*$" str) nil) + (t (concat "^" (regexp-quote str)))))) + (t nil))) + +(defun slime-repl-delete-from-input-history (string) + "Delete STRING from the repl input history. + +When string is not provided then clear the current repl input and +use it as an input. This is useful to get rid of unwanted repl +history entries while navigating the repl history." + (interactive (list (slime-repl-current-input))) + (let ((merged-history + (slime-repl-merge-histories slime-repl-input-history + (slime-repl-read-history nil t)))) + (setq slime-repl-input-history + (delete* string merged-history :test #'string=)) + (slime-repl-save-history)) + (slime-repl-delete-current-input)) + +;;;;; 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. + (let* ((ht (make-hash-table :test #'equal)) + (test (lambda (entry) + (or (gethash entry ht) + (progn (setf (gethash entry ht) t) + nil))))) + (append (remove-if test new-hist) + (remove-if test old-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))) + (with-temp-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) + (print-length nil) (print-level nil)) + (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") + (prin1 (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 Read Mode + +(define-key slime-repl-mode-map + (string slime-repl-shortcut-dispatch-char) 'slime-handle-repl-shortcut) + +(define-minor-mode slime-repl-read-mode + "Mode the read input from Emacs +\{slime-repl-read-mode-map}" + nil + "[read]" + '(("\C-m" . slime-repl-return) + ("\C-c\C-b" . slime-repl-read-break) + ("\C-c\C-c" . slime-repl-read-break))) + +(make-variable-buffer-local + (defvar slime-read-string-threads nil)) + +(make-variable-buffer-local + (defvar slime-read-string-tags nil)) + +(defun slime-repl-read-string (thread tag) + (slime-switch-to-output-buffer) + (push thread slime-read-string-threads) + (push tag slime-read-string-tags) + (goto-char (point-max)) + (slime-mark-output-end) + (slime-mark-input-start) + (slime-repl-read-mode 1)) + +(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 + ,(pop slime-read-string-threads) + ,(pop slime-read-string-tags) + ,string)) + (slime-repl-read-mode -1)) + +(defun slime-repl-read-break () + (interactive) + (slime-dispatch-event `(:emacs-interrupt ,(car slime-read-string-threads)))) + +(defun slime-repl-abort-read (thread tag) + (with-current-buffer (slime-output-buffer) + (pop slime-read-string-threads) + (pop slime-read-string-tags) + (slime-repl-read-mode -1) + (message "Read aborted"))) + + +;;;;; REPL handlers + +(defstruct (slime-repl-shortcut (:conc-name slime-repl-shortcut.)) + symbol names handler one-liner) + +(defvar slime-repl-shortcut-table nil + "A list of slime-repl-shortcuts") + +(defvar slime-repl-shortcut-history '() + "History list of shortcut command names.") + +(defun slime-handle-repl-shortcut () + (interactive) + (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))))) + +(defun slime-list-all-repl-shortcuts () + (loop for shortcut in slime-repl-shortcut-table + append (slime-repl-shortcut.names shortcut))) + +(defun slime-lookup-shortcut (name) + (find-if (lambda (s) (member name (slime-repl-shortcut.names s))) + slime-repl-shortcut-table)) + +(defmacro defslime-repl-shortcut (elisp-name names &rest options) + "Define a new repl shortcut. ELISP-NAME is a symbol specifying + the name of the interactive function to create, or NIL if no + function should be created. NAMES is a list of (full-name . + aliases). OPTIONS is an olist specifying the handler and the + help text." + `(progn + ,(when elisp-name + `(defun ,elisp-name () + (interactive) + (call-interactively ,(second (assoc :handler options))))) + (let ((new-shortcut (make-slime-repl-shortcut + :symbol ',elisp-name + :names (list ,@names) + ,@(apply #'append options)))) + (setq slime-repl-shortcut-table + (remove-if (lambda (s) + (member ',(car names) (slime-repl-shortcut.names s))) + slime-repl-shortcut-table)) + (push new-shortcut slime-repl-shortcut-table) + ',elisp-name))) + +(defun slime-list-repl-short-cuts () + (interactive) + (slime-with-output-to-temp-buffer ("*slime-repl-help*") nil + (let ((table (sort* (copy-list slime-repl-shortcut-table) #'string< + :key (lambda (x) + (car (slime-repl-shortcut.names x)))))) + (dolist (shortcut table) + (let ((names (slime-repl-shortcut.names shortcut))) + (insert (pop names)) ;; first print the "full" name + (when names + ;; we also have aliases + (insert " (aka ") + (while (cdr names) + (insert (pop names) ", ")) + (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) + (:one-liner "Display the help.")) + +(defslime-repl-shortcut nil ("change-directory" "!d" "cd") + (:handler 'slime-set-default-directory) + (:one-liner "Change the current directory.")) + +(defslime-repl-shortcut nil ("pwd") + (:handler (lambda () + (interactive) + (let ((dir (slime-eval `(swank:default-directory)))) + (message "Directory %s" dir)))) + (:one-liner "Show the current directory.")) + +(defslime-repl-shortcut slime-repl-push-directory + ("push-directory" "+d" "pushd") + (:handler (lambda (directory) + (interactive + (list (read-directory-name + "Push directory: " + (slime-eval '(swank:default-directory)) + nil nil ""))) + (push (slime-eval '(swank:default-directory)) + slime-repl-directory-stack) + (slime-set-default-directory directory))) + (:one-liner "Save the current directory and set it to a new one.")) + +(defslime-repl-shortcut slime-repl-pop-directory + ("pop-directory" "-d" "popd") + (:handler (lambda () + (interactive) + (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" "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 (slime-lisp-package) slime-repl-package-stack) + (slime-repl-set-package package))) + (: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) + (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 () + (interactive) + (insert (car slime-repl-input-history)) + (insert "\n") + (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) + (when (slime-connected-p) + (slime-quit-lisp)) + (slime-kill-all-buffers))) + (:one-liner "Quit all Lisps and close all SLIME buffers.")) + +(defslime-repl-shortcut slime-repl-quit ("quit") + (:handler 'slime-quit-lisp) + (:one-liner "Quit the current Lisp.")) + +(defslime-repl-shortcut slime-repl-defparameter ("defparameter" "!") + (:handler (lambda (name value) + (interactive (list (slime-read-symbol-name "Name (symbol): " t) + (slime-read-from-minibuffer "Value: " "*"))) + (insert "(cl:defparameter " name " " value + " "REPL generated global variable.")") + (slime-repl-send-input t))) + (:one-liner "Define a new global, special, variable.")) + +(defslime-repl-shortcut slime-repl-compile-and-load ("compile-and-load" "cl") + (:handler (lambda (filename) + (interactive (list (expand-file-name + (read-file-name "File: " nil nil nil nil)))) + (slime-save-some-lisp-buffers) + (slime-eval-async + `(swank:compile-file-if-needed + ,(slime-to-lisp-filename filename) t) + (slime-make-compilation-finished-continuation (current-buffer))))) + (:one-liner "Compile (if neccessary) and load a lisp file.")) + +(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 () + (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) + "Restart the inferior lisp process. +Also rearrange windows." + (assert (process-status process) 'closed) + (let* ((proc (slime-inferior-process process)) + (args (slime-inferior-lisp-args proc)) + (buffer (buffer-name (process-buffer proc))) + (buffer-window (get-buffer-window buffer)) + (new-proc (slime-start-lisp (plist-get args :program) + (plist-get args :program-args) + nil + 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 args) + (cond ((and repl-window (not buffer-window)) + (set-window-buffer repl-window buffer) + (select-window repl-window)) + (repl-window + (select-window repl-window)) + (t + (pop-to-buffer buffer))) + (switch-to-buffer buffer) + (goto-char (point-max)))) + + +;;;;; Cleanup after a quit + +(defun slime-kill-all-buffers () + "Kill all the slime related buffers. This is only used by the + repl command sayoonara." + (dolist (buf (buffer-list)) + (when (or (string= (buffer-name buf) slime-event-buffer-name) + (string-match "^\*inferior-lisp*" (buffer-name buf)) + (string-match "^\*slime-repl .*\*$" (buffer-name buf)) + (string-match "^\*sldb .*\*$" (buffer-name buf)) + (string-match "^\*SLIME.*\*$" (buffer-name buf))) + (kill-buffer buf)))) + + +;;;; Compilation and the creation of compiler-note annotations + +(defvar slime-highlight-compiler-notes t + "*When non-nil annotate buffers with compilation notes etc.") + +(defcustom slime-display-compilation-output t + "Display the REPL buffer before compiling files." + :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) + :group 'slime-mode) + +(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.") + +(defcustom slime-compilation-finished-hook 'slime-maybe-list-compiler-notes + "Hook called with a list of compiler notes after a compilation." + :group 'slime-mode + :type 'hook + :options '(slime-maybe-list-compiler-notes + 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) + +(defun slime-compile-and-load-file () + "Compile and load the buffer's file and highlight compiler notes. + +Each source location that is the subject of a compiler note is +underlined and annotated with the relevant information. The commands +`slime-next-note' and `slime-previous-note' can be used to navigate +between compiler notes and to display their full details." + (interactive) + (slime-compile-file t)) + +(defun slime-compile-file (&optional load) + "Compile current buffer's file and highlight resulting compiler notes. + +See `slime-compile-and-load-file' for further details." + (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 ((file (slime-to-lisp-filename (buffer-file-name)))) + (slime-insert-transcript-delimiter (format "Compile file %s" file)) + (when slime-display-compilation-output + (slime-display-output-buffer)) + (slime-eval-async + `(swank:compile-file-for-emacs ,file ,(if load t nil)) + (slime-rcurry #'slime-compilation-finished (current-buffer))) + (message "Compiling %s..." file))) + +(defun slime-compile-defun () + "Compile the current toplevel form." + (interactive) + (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) + (slime-eval-async + `(swank:compile-string-for-emacs + ,string + ,(buffer-name) + ,start-offset + ,(if (buffer-file-name) (file-name-directory (buffer-file-name)))) + (slime-make-compilation-finished-continuation (current-buffer)))) + +(defun slime-note-count-string (severity count &optional suppress-if-zero) + (cond ((and (zerop count) suppress-if-zero) + "") + (t (format "%2d %s%s " count severity (if (= count 1) "" "s"))))) + +(defun slime-show-note-counts (notes &optional secs) + (let ((nerrors 0) (nwarnings 0) (nstyle-warnings 0) (nnotes 0)) + (dolist (note notes) + (ecase (slime-note.severity note) + ((:error :read-error) (incf nerrors)) + (: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 t) + (slime-note-count-string "note" nnotes) + (if secs (format "[%s secs]" secs) "")))) + +(defun slime-xrefs-for-notes (notes) + (let ((xrefs)) + (dolist (note notes) + (let* ((location (getf note :location)) + (fn (cadr (assq :file (cdr location)))) + (file (assoc fn xrefs)) + (node + (cons (format "%s: %s" + (getf note :severity) + (slime-one-line-ify (getf note :message))) + location))) + (when fn + (if file + (push node (cdr file)) + (setf xrefs (acons fn (list node) xrefs)))))) + xrefs)) + +(defun slime-one-line-ify (string) + "Return a single-line version of STRING. +Each newlines and following indentation is replaced by a single space." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "\n[\n \t]*" nil t) + (replace-match " ")) + (buffer-string))) + +(defun slime-compilation-finished (result buffer &optional emacs-snapshot) + (let ((notes (slime-compiler-notes))) + (with-current-buffer buffer + (setf slime-compilation-just-finished t) + (destructuring-bind (result secs) result + (slime-show-note-counts notes secs) + (when slime-highlight-compiler-notes + (slime-highlight-notes notes)))) + (run-hook-with-args 'slime-compilation-finished-hook notes emacs-snapshot))) + +(defun slime-make-compilation-finished-continuation (current-buffer &optional emacs-snapshot) + (lexical-let ((buffer current-buffer) (snapshot emacs-snapshot)) + (lambda (result) + (slime-compilation-finished result buffer snapshot)))) + +(defun slime-highlight-notes (notes) + "Highlight compiler notes, warnings, and errors in the buffer." + (interactive (list (slime-compiler-notes))) + (with-temp-message "Highlighting notes..." + (save-excursion + (save-restriction + (widen) ; highlight notes on the whole buffer + (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." + (slime-eval `(swank:compiler-notes-for-emacs))) + +(defun slime-remove-old-overlays () + "Delete the existing Slime overlays in the current buffer." + (dolist (buffer (slime-filter-buffers (lambda () slime-mode))) + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) ; remove overlays within the whole buffer. + (goto-char (point-min)) + (while (not (eobp)) + (dolist (o (overlays-at (point))) + (when (overlay-get o 'slime) + (delete-overlay o))) + (goto-char (next-overlay-change (point))))))))) + +(defun slime-filter-buffers (predicate) + "Return a list of where PREDICATE returns true. +PREDICATE is executed in the buffer to test." + (remove-if-not (lambda (%buffer) + (with-current-buffer %buffer + (funcall predicate))) + (buffer-list))) + + +;;;;; Merging together compiler notes in the same location. + +(defun slime-merge-notes-for-display (notes) + "Merge together notes that refer to the same location. +This operation is "lossy" in the broad sense but not for display purposes." + (mapcar #'slime-merge-notes + (slime-group-similar 'slime-notes-in-same-location-p notes))) + +(defun slime-merge-notes (notes) + "Merge NOTES together. Keep the highest severity, concatenate the messages." + (let* ((new-severity (reduce #'slime-most-severe notes + :key #'slime-note.severity)) + (new-message (mapconcat #'slime-note.short-message notes "\n"))) + (let ((new-note (copy-list (car notes)))) + (setf (getf new-note :message) new-message) + (setf (getf new-note :severity) new-severity) + new-note))) + +;; XXX: unused function +(defun slime-intersperse (element list) + "Intersperse ELEMENT between each element of LIST." + (if (null list) + '() + (cons (car list) + (mapcan (lambda (x) (list element x)) (cdr list))))) + +(defun slime-notes-in-same-location-p (a b) + (equal (slime-note.location a) (slime-note.location b))) + +(defun slime-group-similar (similar-p list) + "Return the list of lists of 'similar' adjacent elements of LIST. +The function SIMILAR-P is used to test for similarity. +The order of the input list is preserved." + (if (null list) + nil + (let ((accumulator (list (list (car list))))) + (dolist (x (cdr list)) + (if (funcall similar-p x (caar accumulator)) + (push x (car accumulator)) + (push (list x) accumulator))) + (reverse (mapcar #'reverse accumulator))))) + + +;;;;; Compiler notes list + +(defun slime-maybe-show-xrefs-for-notes (&optional notes emacs-snapshot) + "Show the compiler notes NOTES if they come from more than one file." + (let* ((notes (or notes (slime-compiler-notes))) + (xrefs (slime-xrefs-for-notes notes))) + (when (slime-length> xrefs 1) ; >1 file + (slime-show-xrefs + xrefs 'definition "Compiler notes" (slime-current-package) + emacs-snapshot)))) + +(defun slime-note-has-location-p (note) + (not (eq ':error (car (slime-note.location note))))) + +(defun slime-maybe-list-compiler-notes (notes &optional emacs-snapshot) + "Show the compiler notes if appropriate." + ;; don't pop up a buffer if all notes are already annotated in the + ;; buffer itself + (unless (every #'slime-note-has-location-p notes) + (slime-list-compiler-notes notes emacs-snapshot))) + +(defun slime-list-compiler-notes (notes &optional emacs-snapshot) + "Show the compiler notes NOTES in tree view." + (interactive (list (slime-compiler-notes))) + (with-temp-message "Preparing compiler note tree..." + (with-current-buffer + (slime-get-temp-buffer-create "*compiler notes*" + :mode 'slime-compiler-notes-mode + :emacs-snapshot emacs-snapshot) + (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 from an element and TEST is used to compare keys." + (declare (type function key)) + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (assoc* k alist :test test))) + (if probe + (push e (cdr probe)) + (push (cons k (list e)) alist)))) + ;; Put them back in order. + (loop for (key . value) in alist + collect (cons key (reverse value))))) + +(defun slime-note.severity (note) + (plist-get note :severity)) + +(defun slime-note.message (note) + (plist-get note :message)) + +(defun slime-note.short-message (note) + (or (plist-get note :short-message) + (plist-get note :message))) + +(defun slime-note.location (note) + (plist-get note :location)) + +(defun slime-severity-label (severity) + (ecase severity + (:note "Notes") + (:warning "Warnings") + (:error "Errors") + (:read-error "Read Errors") + (:style-warning "Style Warnings"))) + +(defvar slime-tree-printer 'slime-tree-default-printer) + +(defun slime-tree-for-note (note) + (make-slime-tree :item (slime-note.message note) + :plist (list 'note note) + :print-fn slime-tree-printer)) + +(defun slime-tree-for-severity (severity notes collapsed-p) + (make-slime-tree :item (format "%s (%d)" + (slime-severity-label severity) + (length notes)) + :kids (mapcar #'slime-tree-for-note notes) + :collapsed-p collapsed-p)) + +(defun slime-compiler-notes-to-tree (notes) + (let* ((alist (slime-alistify notes #'slime-note.severity #'eq)) + (collapsed-p (slime-length> alist 1))) + (loop for (severity . notes) in alist + collect (slime-tree-for-severity severity notes + collapsed-p)))) + +(defvar slime-compiler-notes-mode-map) + +(define-derived-mode slime-compiler-notes-mode fundamental-mode + "Compiler Notes" + "\<slime-compiler-notes-mode-map>\ +\{slime-compiler-notes-mode-map}" + (slime-set-truncate-lines)) + +(slime-define-keys slime-compiler-notes-mode-map + ((kbd "RET") 'slime-compiler-notes-default-action-or-show-details) + ([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse) + ("q" 'slime-temp-buffer-quit)) + +(defun slime-compiler-notes-default-action-or-show-details/mouse (event) + "Invoke the action pointed at by the mouse, or show details." + (interactive "e") + (destructuring-bind (mouse-2 (w pos &rest _) &rest __) event + (save-excursion + (goto-char pos) + (let ((fn (get-text-property (point) + 'slime-compiler-notes-default-action))) + (if fn (funcall fn) (slime-compiler-notes-show-details)))))) + +(defun slime-compiler-notes-default-action-or-show-details () + "Invoke the action at point, or show details." + (interactive) + (let ((fn (get-text-property (point) 'slime-compiler-notes-default-action))) + (if fn (funcall fn) (slime-compiler-notes-show-details)))) + +(defun slime-compiler-notes-show-details () + (interactive) + (let* ((tree (slime-tree-at-point)) + (note (plist-get (slime-tree.plist tree) 'note)) + (inhibit-read-only t)) + (cond ((not (slime-tree-leaf-p tree)) + (slime-tree-toggle tree)) + (t + (slime-show-source-location (slime-note.location note) t))))) + + +;;;;;; Tree Widget + +(defstruct (slime-tree (:conc-name slime-tree.)) + item + (print-fn #'slime-tree-default-printer :type function) + (kids '() :type list) + (collapsed-p t :type boolean) + (prefix "" :type string) + (start-mark nil) + (end-mark nil) + (plist '() :type list)) + +(defun slime-tree-leaf-p (tree) + (not (slime-tree.kids tree))) + +(defun slime-tree-default-printer (tree) + (princ (slime-tree.item tree) (current-buffer))) + +(defun slime-tree-decoration (tree) + (cond ((slime-tree-leaf-p tree) "-- ") + ((slime-tree.collapsed-p tree) "[+] ") + (t "-+ "))) + +(defun slime-tree-insert-list (list prefix) + "Insert a list of trees." + (loop for (elt . rest) on list + do (cond (rest + (insert prefix " |") + (slime-tree-insert elt (concat prefix " |")) + (insert "\n")) + (t + (insert prefix " `") + (slime-tree-insert elt (concat prefix " ")))))) + +(defun slime-tree-insert-decoration (tree) + (insert (slime-tree-decoration tree))) + +(defun slime-tree-indent-item (start end prefix) + "Insert PREFIX at the beginning of each but the first line. +This is used for labels spanning multiple lines." + (save-excursion + (goto-char end) + (beginning-of-line) + (while (< start (point)) + (insert-before-markers prefix) + (forward-line -1)))) + +(defun slime-tree-insert (tree prefix) + "Insert TREE prefixed with PREFIX at point." + (with-struct (slime-tree. print-fn kids collapsed-p start-mark end-mark) tree + (let ((line-start (line-beginning-position))) + (setf start-mark (point-marker)) + (slime-tree-insert-decoration tree) + (funcall print-fn tree) + (slime-tree-indent-item start-mark (point) (concat prefix " ")) + (add-text-properties line-start (point) (list 'slime-tree tree)) + (set-marker-insertion-type start-mark t) + (when (and kids (not collapsed-p)) + (terpri (current-buffer)) + (slime-tree-insert-list kids prefix)) + (setf (slime-tree.prefix tree) prefix) + (setf end-mark (point-marker))))) + +(defun slime-tree-at-point () + (cond ((get-text-property (point) 'slime-tree)) + (t (error "No tree at point")))) + +(defun slime-tree-delete (tree) + "Delete the region for TREE." + (delete-region (slime-tree.start-mark tree) + (slime-tree.end-mark tree))) + +(defun slime-tree-toggle (tree) + "Toggle the visibility of TREE's children." + (with-struct (slime-tree. collapsed-p start-mark end-mark prefix) tree + (setf collapsed-p (not collapsed-p)) + (slime-tree-delete tree) + (insert-before-markers " ") ; move parent's end-mark + (backward-char 1) + (slime-tree-insert tree prefix) + (delete-char 1) + (goto-char start-mark))) + + +;;;;; Adding a single compiler note + +(defun slime-overlay-note (note) + "Add a compiler note to the buffer as an overlay. +If an appropriate overlay for a compiler note in the same location +already exists then the new information is merged into it. Otherwise a +new overlay is created." + (multiple-value-bind (start end) (slime-choose-overlay-region note) + (when start + (goto-char start) + (let ((severity (plist-get note :severity)) + (message (plist-get note :message)) + (overlay (slime-note-at-point))) + (if overlay + (slime-merge-note-into-overlay overlay severity message) + (slime-create-note-overlay note start end severity message)))))) + +(defun slime-create-note-overlay (note start end severity message) + "Create an overlay representing a compiler note. +The overlay has several properties: + FACE - to underline the relevant text. + SEVERITY - for future reference, :NOTE, :STYLE-WARNING, :WARNING, or :ERROR. + MOUSE-FACE - highlight the note when the mouse passes over. + HELP-ECHO - a string describing the note, both for future reference + and for display as a tooltip (due to the special + property name)." + (let ((overlay (make-overlay start end))) + (flet ((putp (name value) (overlay-put overlay name value))) + (putp 'slime note) + (putp 'face (slime-severity-face severity)) + (putp 'severity severity) + (unless (slime-emacs-20-p) + (putp 'mouse-face 'highlight)) + (putp 'help-echo message) + overlay))) + +;; XXX Obsolete due to `slime-merge-notes-for-display' doing the +;; work already -- unless we decide to put several sets of notes on a +;; buffer without clearing in between, which only this handles. +(defun slime-merge-note-into-overlay (overlay severity message) + "Merge another compiler note into an existing overlay. +The help text describes both notes, and the highest of the severities +is kept." + (flet ((putp (name value) (overlay-put overlay name value)) + (getp (name) (overlay-get overlay name))) + (putp 'severity (slime-most-severe severity (getp 'severity))) + (putp 'face (slime-severity-face (getp 'severity))) + (putp 'help-echo (concat (getp 'help-echo) "\n" message)))) + +(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. +Return nil if there's no useful source location." + (let ((location (slime-note.location note))) + (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) + (skip-chars-forward "'#`") + (let ((start (point))) + (ignore-errors (slime-forward-sexp)) + (if (slime-same-line-p start (point)) + (values start (point)) + (values (1+ start) + (progn (goto-char (1+ start)) + (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)))) + +(defun slime-severity-face (severity) + "Return the name of the font-lock face representing SEVERITY." + (ecase severity + (:error 'slime-error-face) + (:read-error 'slime-error-face) + (:warning 'slime-warning-face) + (:style-warning 'slime-style-warning-face) + (:note 'slime-note-face))) + +(defun slime-most-severe (sev1 sev2) + "Return the most servere of two conditions. +Severity is ordered as :NOTE < :STYLE-WARNING < :WARNING < :ERROR." + ; Well, not exactly Smullyan.. + (let ((order '(:note :style-warning :warning :error :read-error))) + (if (>= (position sev1 order) + (position sev2 order)) + sev1 + sev2))) + +;; XXX: unused function +(defun slime-visit-source-path (source-path) + "Visit a full source path including the top-level form." + (goto-char (point-min)) + (slime-forward-source-path source-path)) + +(defun slime-forward-positioned-source-path (source-path) + "Move forward through a sourcepath from a fixed position. +The point is assumed to already be at the outermost sexp, making the +first element of the source-path redundant." + (ignore-errors + (slime-forward-sexp) + (beginning-of-defun)) + (when-let (source-path (cdr source-path)) + (down-list 1) + (slime-forward-source-path source-path))) + +(defun slime-forward-source-path (source-path) + (let ((origin (point))) + (condition-case nil + (progn + (loop for (count . more) on source-path + do (progn + (slime-forward-sexp count) + (when more (down-list 1)))) + ;; Align at beginning + (slime-forward-sexp) + (beginning-of-sexp)) + (error (goto-char origin))))) + +(defun slime-filesystem-toplevel-directory () + ;; Windows doesn't have a true toplevel root directory, and all + ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs + ;; perspective anyway. + (if (memq system-type '(ms-dos windows-nt)) + "" + (file-name-as-directory "/"))) + +(defun slime-file-name-merge-source-root (target-filename buffer-filename) + "Returns a filename where the source root directory of TARGET-FILENAME +is replaced with the source root directory of BUFFER-FILENAME. + +If no common source root could be determined, return NIL. + +E.g. (slime-file-name-merge-source-root + "/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp" + "/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp") + + ==> "/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp" +" + (let ((target-dirs (slime-split-string (file-name-directory target-filename) "/" t)) + (buffer-dirs (slime-split-string (file-name-directory buffer-filename) "/" t))) + ;; Starting from the end, we look if one of the TARGET-DIRS exists + ;; in BUFFER-FILENAME---if so, it and everything left from that dirname + ;; is considered to be the source root directory of BUFFER-FILENAME. + (loop with target-suffix-dirs = nil + with buffer-dirs* = (reverse buffer-dirs) + with target-dirs* = (reverse target-dirs) + for target-dir in target-dirs* + do (flet ((concat-dirs (dirs) + (apply #'concat (mapcar #'file-name-as-directory dirs)))) + (let ((pos (position target-dir buffer-dirs* :test #'equal))) + (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME? + (push target-dir target-suffix-dirs) + (let* ((target-suffix (concat-dirs target-suffix-dirs)) ; PUSH reversed for us! + (buffer-root (concat-dirs (reverse (nthcdr pos buffer-dirs*))))) + (return (concat (slime-filesystem-toplevel-directory) + buffer-root + target-suffix + (file-name-nondirectory target-filename)))))))))) + +(defun slime-highlight-differences-in-dirname (base-dirname contrast-dirname) + "Returns a copy of BASE-DIRNAME where all differences between +BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a +highlighting face." + (setq base-dirname (file-name-as-directory base-dirname)) + (setq contrast-dirname (file-name-as-directory contrast-dirname)) + (flet ((insert-dir (dirname) + (insert (file-name-as-directory dirname))) + (insert-dir/propzd (dirname) + (slime-insert-propertized '(face highlight) dirname) + (insert "/"))) ; Not exactly portable (to VMS...) + (let ((base-dirs (slime-split-string base-dirname "/" t)) + (contrast-dirs (slime-split-string contrast-dirname "/" t))) + (with-temp-buffer + (loop initially (insert (slime-filesystem-toplevel-directory)) + for base-dir in base-dirs do + (let ((pos (position base-dir contrast-dirs :test #'equal))) + (if (not pos) + (insert-dir/propzd base-dir) + (progn (insert-dir base-dir) + (setq contrast-dirs (nthcdr (1+ pos) contrast-dirs)))))) + (buffer-substring (point-min) (point-max)))))) + +(defvar slime-warn-when-possibly-tricked-by-M-. t + "When working on multiple source trees simultaneously, the way +`slime-edit-definition' (M-.) works can sometimes be confusing: + +`M-.' visits locations that are present in the current Lisp image, +which works perfectly well as long as the image reflects the source +tree that one is currently looking at. + +In the other case, however, one can easily end up visiting a file +in a different source root directory (the one corresponding to +the Lisp image), and is thus easily tricked to modify the wrong +source files---which can lead to quite some stressfull cursing. + +If this variable is T, a warning message is issued to raise the +user's attention whenever `M-.' is about opening a file in a +different source root that also exists in the source root +directory of the user's current buffer. + +There's no guarantee that all possible cases are covered, but +if you encounter such a warning, it's a strong indication that +you should check twice before modifying.") + +(defun slime-maybe-warn-for-different-source-root (target-filename buffer-filename) + (when slime-warn-when-possibly-tricked-by-M-. + (let ((guessed-target (slime-file-name-merge-source-root target-filename + buffer-filename))) + (when (and guessed-target + (not (equal guessed-target target-filename)) + (file-exists-p guessed-target)) + (slime-message "Attention: This is `%s'." + (concat (slime-highlight-differences-in-dirname + (file-name-directory target-filename) + (file-name-directory guessed-target)) + (file-name-nondirectory target-filename))))))) + + +(defun slime-goto-location-buffer (buffer) + (flet ((file-truename-safe (filename) (and filename (file-truename filename)))) + (destructure-case buffer + ((:file filename) + (let ((target-filename (file-truename-safe (slime-from-lisp-filename filename))) + (buffer-filename (file-truename-safe (buffer-file-name)))) + (when buffer-filename + (slime-maybe-warn-for-different-source-root target-filename buffer-filename)) + (unless (and buffer-filename (string= buffer-filename target-filename)) + (set-buffer (find-file-noselect target-filename t)))) + (goto-char (point-min))) + ((:buffer buffer-name) + (let ((old-buffer-filename (file-truename-safe (buffer-file-name))) + (target-buffer-filename (file-truename-safe + (buffer-file-name (get-buffer buffer-name))))) + (when (and target-buffer-filename old-buffer-filename) + (slime-maybe-warn-for-different-source-root target-buffer-filename + old-buffer-filename))) + (set-buffer buffer-name) + (goto-char (point-min))) + ((:source-form string) + (set-buffer (get-buffer-create "*SLIME Source Form*")) + (erase-buffer) + (lisp-mode) + (insert string) + (goto-char (point-min))) + ((:zip file entry) + (require 'arc-mode) + (set-buffer (find-file-noselect file t)) + (goto-char (point-min)) + (re-search-forward (concat " " entry "$")) + (let ((buffer (save-window-excursion + (archive-extract) + (current-buffer)))) + (set-buffer buffer) + (goto-char (point-min))))))) + +(defun slime-goto-location-position (position) + (save-restriction-if-possible ; try to keep restriction if possible. + (widen) + (destructure-case position + ((:position pos &optional align-p) + (goto-char pos) + (when align-p + (slime-forward-sexp) + (beginning-of-sexp))) + ((:line start &optional column) + (goto-line start) + (cond (column (move-to-column column)) + (t (skip-chars-forward " \t")))) + ((:function-name name) + (let ((case-fold-search t) + (name (regexp-quote name))) + (or + (re-search-forward + (format "\s *(def\(\s_\|\sw\)*\s +%s\S_" name) nil t) + (re-search-forward + (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))) + ((:method name specializers &rest qualifiers) + (slime-search-method-location name specializers qualifiers)) + ((:source-path source-path start-position) + (cond (start-position + (goto-char start-position) + (slime-forward-positioned-source-path source-path)) + (t + (slime-forward-source-path source-path)))) + ;; Goes to "start" then looks for the anchor text, then moves + ;; delta from that position. + ((:text-anchored start text delta) + (goto-char start) + (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." + (save-restriction + (narrow-to-defun) + (let ((start (point)) + (regexp (concat "(" fname "[\n \t]"))) + (cond ((and (re-search-forward regexp nil t) + (not (re-search-forward regexp nil t))) + (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: + +<location> ::= (:location <buffer> <position> <hints>) + | (:error <message>) + +<buffer> ::= (:file <filename>) + | (:buffer <buffername>) + | (:source-form <string>) + | (:zip <file> <entry>) + +<position> ::= (:position <fixnum> [<align>]) ; 1 based + | (:line <line> [<column>]) + | (:function-name <string>) + | (:source-path <list> <start-position>) + | (:text-anchored <fixnum> <string> <fixnum>) + | (:method <name string> <specializer strings> . <qualifiers strings>)" + (destructure-case location + ((:location buffer position hints) + (slime-goto-location-buffer buffer) + (slime-goto-location-position position) + (when-let (snippet (getf hints :snippet)) + (slime-isearch snippet)) + (when-let (fname (getf hints :call-site)) + (slime-search-call-site fname))) + ((:error message) + (if noerror + (slime-message "%s" message) + (error "%s" message))))) + +(defmacro slime-point-moves-p (&rest body) + "Execute BODY and return true if the current buffer's point moved." + (let ((pointvar (gensym "point-"))) + `(let ((,pointvar (point))) + (save-current-buffer ,@body) + (/= ,pointvar (point))))) + +(put 'slime-point-moves-p 'lisp-indent-function 0) + +(defun slime-forward-sexp (&optional count) + "Like `forward-sexp', but understands reader-conditionals (#- and #+)." + (dotimes (i (or count 1)) + (while (slime-point-moves-p (slime-forward-blanks) + (slime-forward-reader-comment) + (slime-forward-reader-conditional))) + (forward-sexp))) + +(defun slime-forward-blanks () + "Move forward over all whitespace and newlines at point." + (ignore-errors + (while (slime-point-moves-p + (skip-syntax-forward " ") + ;; newlines aren't in lisp-mode's whitespace syntax class + (when (eolp) (forward-char)))))) + +;; Emacs 21's forward-sexp understands #| |# comments in lisp-mode +;; buffers, but (at least) Emacs 20's doesn't, so here it is. +(defun slime-forward-reader-comment () + "Move forward over #|...|# reader comments. The comments may be nested." + (when (looking-at "#|") + (goto-char (match-end 0)) + (while (not (looking-at "|#")) + (re-search-forward (regexp-opt '("|#" "#|"))) + (goto-char (match-beginning 0)) + (when (looking-at "#|") ; nested comment + (slime-forward-reader-comment))) + (goto-char (match-end 0)))) + +(defun slime-forward-reader-conditional () + "Move past any reader conditional (#+ or #-) at point." + (when (or (looking-at "#\+") + (looking-at "#-")) + (goto-char (match-end 0)) + (let* ((plus-conditional-p (eq (char-before) ?+)) + (result (slime-eval-feature-conditional (read (current-buffer))))) + (unless (if plus-conditional-p result (not result)) + ;; skip this sexp + (slime-forward-sexp))))) + +(defun slime-keywordify (symbol) + "Make a keyword out of the symbol SYMBOL." + (let ((name (downcase (symbol-name symbol)))) + (intern (if (eq ?: (aref name 0)) + name + (concat ":" name))))) + +(defun slime-eval-feature-conditional (e) + "Interpret a reader conditional expression." + (if (symbolp e) + (memq (slime-keywordify e) (slime-lisp-features)) + (funcall (ecase (slime-keywordify (car e)) + (:and #'every) + (:or #'some) + (:not (lambda (f l) (not (apply f l))))) + #'slime-eval-feature-conditional + (cdr e)))) + + +;;;;; Incremental search +;; +;; Search for the longest match of a string in either direction. +;; +;; This is for locating text that is expected to be near the point and +;; may have been modified (but hopefully not near the beginning!) + +(defun slime-isearch (string) + "Find the longest occurence of STRING either backwards of forwards. +If multiple matches exist the choose the one nearest to point." + (goto-char + (let* ((start (point)) + (len1 (slime-isearch-with-function 'search-forward string)) + (pos1 (point))) + (goto-char start) + (let* ((len2 (slime-isearch-with-function 'search-backward string)) + (pos2 (point))) + (cond ((and len1 len2) + ;; Have a match in both directions + (cond ((= len1 len2) + ;; Both are full matches -- choose the nearest. + (if (< (abs (- start pos1)) + (abs (- start pos2))) + pos1 pos2)) + ((> len1 len2) pos1) + ((> len2 len1) pos2))) + (len1 pos1) + (len2 pos2) + (t start)))))) + +(defun slime-isearch-with-function (search-fn string) + "Search for the longest substring of STRING using SEARCH-FN. +SEARCH-FN is either the symbol `search-forward' or `search-backward'." + (unless (string= string "") + (loop for i from 1 to (length string) + while (funcall search-fn (substring string 0 i) nil t) + for match-data = (match-data) + do (case search-fn + (search-forward (goto-char (match-beginning 0))) + (search-backward (goto-char (1+ (match-end 0))))) + finally (return (if (null match-data) + nil + ;; Finish based on the last successful match + (store-match-data match-data) + (goto-char (match-beginning 0)) + (- (match-end 0) (match-beginning 0))))))) + + +;;;;; 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) + (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) + (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." + (interactive) + (slime-remove-old-overlays)) + +(defun slime-show-note (overlay) + "Present the details of a compiler note to the user." + (slime-temporarily-highlight-note overlay) + (let ((message (get-char-property (point) 'help-echo))) + (slime-message "%s" (if (zerop (length message)) """" message)))) + +(defun slime-temporarily-highlight-note (overlay) + "Temporarily highlight a compiler note's overlay. +The highlighting is designed to both make the relevant source more +visible, and to highlight any further notes that are nested inside the +current one. + +The highlighting is automatically undone before the next Emacs command." + (lexical-let ((old-face (overlay-get overlay 'face)) + (overlay overlay)) + (push (lambda () (overlay-put overlay 'face old-face)) + slime-pre-command-actions) + (overlay-put overlay 'face 'slime-highlight-face))) + + +;;;;; Overlay lookup operations + +(defun slime-note-at-point () + "Return the overlay for a note starting at point, otherwise NIL." + (find (point) (slime-note-overlays-at-point) + :key 'overlay-start)) + +(defun slime-note-overlay-p (overlay) + "Return true if OVERLAY represents a compiler note." + (overlay-get overlay 'slime)) + +(defun slime-note-overlays-at-point () + "Return a list of all note overlays that are under the point." + (remove-if-not 'slime-note-overlay-p (overlays-at (point)))) + +(defun slime-find-next-note () + "Go to the next position with the `slime-note' text property. +Retuns true if such a position is found." + (slime-find-note 'next-single-char-property-change)) + +(defun slime-find-previous-note () + "Go to the next position with the `slime' text property. +Returns true if such a position is found." + (slime-find-note 'previous-single-char-property-change)) + +(defun slime-find-note (next-candidate-fn) + "Seek out the beginning of a note. +NEXT-CANDIDATE-FN is called to find each new position for consideration." + (let ((origin (point))) + (loop do (goto-char (funcall next-candidate-fn (point) 'slime)) + until (or (slime-note-at-point) + (eobp) + (bobp))) + (unless (slime-note-at-point) + (goto-char origin)))) + + +;;;; Arglist Display + +(defun slime-space (n) + "Insert a space and print some relevant information (function arglist). +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) + (when (and slime-space-information-p + (slime-background-activities-enabled-p)) + (slime-echo-arglist))) + +(defvar slime-echo-arglist-function 'slime-show-arglist) + +(defun slime-echo-arglist () + "Display the arglist of the current form in the echo area." + (funcall slime-echo-arglist-function)) + +(defun slime-show-arglist () + (let ((op (slime-operator-before-point))) + (when op + (slime-eval-async `(swank:operator-arglist ,op ,(slime-current-package)) + (lambda (arglist) + (when arglist + (slime-message "%s" arglist))))))) + +(defun slime-operator-before-point () + (ignore-errors + (save-excursion + (backward-up-list 1) + (down-list 1) + (slime-symbol-name-at-point)))) + + +;;;; Completion + +;; XXX those long names are ugly to read; long names an indicator for +;; bad factoring? + +(defvar slime-completions-buffer-name "*Completions*") + +(make-variable-buffer-local + (defvar slime-complete-saved-window-configuration nil + "Window configuration before we show the *Completions* buffer. +This is buffer local in the buffer where the completion is +performed.")) + +(make-variable-buffer-local + (defvar slime-completions-window nil + "The window displaying *Completions* after saving window configuration. +If this window is no longer active or displaying the completions +buffer then we can ignore `slime-complete-saved-window-configuration'.")) + +(defun slime-complete-maybe-save-window-configuration () + "Maybe save the current window configuration. +Return true if the configuration was saved." + (unless (or slime-complete-saved-window-configuration + (get-buffer-window slime-completions-buffer-name)) + (setq slime-complete-saved-window-configuration + (current-window-configuration)) + t)) + +(defun slime-complete-delay-restoration () + (make-local-hook 'pre-command-hook) + (add-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-configuration)) + +(defun slime-complete-forget-window-configuration () + (setq slime-complete-saved-window-configuration nil) + (setq slime-completions-window nil)) + +(defun slime-complete-restore-window-configuration () + "Restore the window config if available." + (remove-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-configuration) + (when (and slime-complete-saved-window-configuration + (slime-completion-window-active-p)) + ;; XEmacs does not allow us to restore a window configuration from + ;; pre-command-hook, so we do it asynchronously. + (slime-run-when-idle + (lambda () + (save-excursion + (set-window-configuration + slime-complete-saved-window-configuration)) + (setq slime-complete-saved-window-configuration nil) + (when (buffer-live-p slime-completions-buffer-name) + (kill-buffer slime-completions-buffer-name)))))) + +(defun slime-complete-maybe-restore-window-configuration () + "Restore the window configuration, if the following command +terminates a current completion." + (remove-hook 'pre-command-hook + 'slime-complete-maybe-restore-window-configuration) + (condition-case err + (cond ((find last-command-char "()"'`,# \r\n:") + (slime-complete-restore-window-configuration)) + ((not (slime-completion-window-active-p)) + (slime-complete-forget-window-configuration)) + (t + (slime-complete-delay-restoration))) + (error + ;; Because this is called on the pre-command-hook, we mustn't let + ;; errors propagate. + (message "Error in slime-complete-restore-window-configuration: %S" err)))) + +(defun slime-completion-window-active-p () + "Is the completion window currently active?" + (and (window-live-p slime-completions-window) + (equal (buffer-name (window-buffer slime-completions-window)) + slime-completions-buffer-name))) + +(defun slime-display-completion-list (completions base) + (let ((savedp (slime-complete-maybe-save-window-configuration))) + (with-output-to-temp-buffer slime-completions-buffer-name + (display-completion-list completions) + (let ((offset (- (point) 1 (length base)))) + (with-current-buffer standard-output + (setq completion-base-size offset) + (set-syntax-table lisp-mode-syntax-table)))) + (when savedp + (setq slime-completions-window + (get-buffer-window slime-completions-buffer-name))))) + +(defun slime-display-or-scroll-completions (completions base) + (cond ((and (eq last-command this-command) + (slime-completion-window-active-p)) + (slime-scroll-completions)) + (t + (slime-display-completion-list completions base))) + (slime-complete-delay-restoration)) + +(defun slime-scroll-completions () + (let ((window slime-completions-window)) + (with-current-buffer (window-buffer window) + (if (pos-visible-in-window-p (point-max) window) + (set-window-start window (point-min)) + (save-selected-window + (select-window window) + (scroll-up)))))) + +(defun slime-complete-symbol () + "Complete the symbol at point. + +Completion is performed by `slime-complete-symbol-function'." + (interactive) + (funcall slime-complete-symbol-function)) + +(defun slime-simple-complete-symbol () + "Complete the symbol at point. +Perform completion more similar to Emacs' complete-symbol." + (or (slime-maybe-complete-as-filename) + (let* ((end (point)) + (beg (slime-symbol-start-pos)) + (prefix (buffer-substring-no-properties beg end)) + (result (slime-simple-completions prefix))) + (destructuring-bind (completions partial) result + (if (null completions) + (progn (slime-minibuffer-respecting-message + "Can't find completion for "%s"" prefix) + (ding) + (slime-complete-restore-window-configuration)) + (insert-and-inherit (substring partial (length prefix))) + (cond ((slime-length= completions 1) + (slime-minibuffer-respecting-message "Sole completion") + (slime-complete-restore-window-configuration)) + ;; Incomplete + (t + (slime-minibuffer-respecting-message + "Complete but not unique") + (slime-display-or-scroll-completions completions + partial)))))))) + +(defun slime-maybe-complete-as-filename () + "If point is at a string starting with ", complete it as filename. +Return nil iff if point is not at filename." + (if (save-excursion (re-search-backward ""[^ \t\n]+\=" nil t)) + (let ((comint-completion-addsuffix '("/" . """))) + (if slime-when-complete-filename-expand + (comint-replace-by-expanded-filename) + (comint-dynamic-complete-as-filename)) + t) + nil)) + +(defun slime-minibuffer-respecting-message (format &rest format-args) + "Display TEXT as a message, without hiding any minibuffer contents." + (let ((text (format " [%s]" (apply #'format format format-args)))) + (if (minibuffer-window-active-p (minibuffer-window)) + (if (fboundp 'temp-minibuffer-message) ;; XEmacs + (temp-minibuffer-message text) + (minibuffer-message text)) + (message "%s" text)))) + +(defvar slime-read-expression-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "\t" 'slime-complete-symbol) + (define-key map "\M-\t" 'slime-complete-symbol) + map) + "Minibuffer keymap used for reading CL expressions.") + +(defvar slime-read-expression-history '() + "History list of expressions read from the minibuffer.") + +(defun slime-read-from-minibuffer (prompt &optional initial-value) + "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)." + (let ((minibuffer-setup-hook + (cons (lexical-let ((package (slime-current-package)) + (connection (slime-connection))) + (lambda () + (setq slime-buffer-package package) + (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 + nil 'slime-read-expression-history))) + +(defun slime-bogus-completion-alist (list) + "Make an alist out of list. +The same elements go in the CAR, and nil in the CDR. To support the +apparently very stupid `try-completions' interface, that wants an +alist but ignores CDRs." + (mapcar (lambda (x) (cons x nil)) list)) + +(defun slime-simple-completions (prefix) + (slime-eval `(swank:simple-completions ,prefix ',(slime-current-package)))) + + +;;;; Edit definition + +(defvar slime-find-definition-history-ring (make-ring 20) + "History ring recording the definition-finding "stack".") + +(defun slime-push-definition-stack (&optional marker narrowing-configuration) + "Add MARKER and NARROWING-CONFIGURATION to the edit-definition history stack. +If MARKER is nil, use the current point. If NARROWING-CONFIGURATION is nil, +look if the current buffer is narrowed, and if so use the relevant values." + (ring-insert-at-beginning slime-find-definition-history-ring + (list (or marker (point-marker)) + (or narrowing-configuration + (slime-current-narrowing-configuration))))) + +(defun slime-pop-find-definition-stack () + "Pop the edit-definition stack and goto the location." + (interactive) + (unless (ring-empty-p slime-find-definition-history-ring) + (destructuring-bind (marker narrowing-cfg) + (ring-remove slime-find-definition-history-ring) + (let ((buffer (marker-buffer marker)) + (narrowedp (slime-narrowing-configuration.narrowedp narrowing-cfg)) + (narrow-beg (slime-narrowing-configuration.beg narrowing-cfg)) + (narrow-end (slime-narrowing-configuration.end narrowing-cfg))) + (if (buffer-live-p buffer) + (progn (switch-to-buffer buffer) + (goto-char (marker-position marker)) + (when narrowedp + (narrow-to-region narrow-beg narrow-end))) + ;; If this buffer was deleted, recurse to try the next one + (slime-pop-find-definition-stack)))))) + +(defstruct (slime-definition (:conc-name slime-definition.) + (:type list)) + dspec location) + +(defun slime-edit-definition (name &optional where) + "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 "Name: "))) + (let ((definitions (slime-eval `(swank:find-definitions-for-emacs ,name)))) + (cond + ((null definitions) + (if slime-edit-definition-fallback-function + (funcall slime-edit-definition-fallback-function name) + (error "No known definition for: %s" name))) + ((and (slime-length= definitions 1) + (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-find-tag-if-tags-table-visited (name) + "Find tag (in current tags table) whose name contains NAME. +If no tags table is visited, don't offer to visit one; +just signal that no definition is known." + (if tags-table-list + (find-tag name) + (error "No known definition for: %s; use M-x visit-tags-table RET" name))) + +(defun slime-goto-definition (name definitions &optional where) + (slime-push-definition-stack) + (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) + (slime-goto-source-location (slime-definition.location definition)) + (switch-to-buffer (current-buffer))) + +(defun slime-pop-to-other-window () + "Pop to the other window, but not to any particular buffer." + (pop-to-buffer (current-buffer) t)) + +(defun slime-edit-definition-other-window (name) + "Like `slime-edit-definition' but switch to the other window." + (interactive (list (slime-read-symbol-name "Symbol: "))) + (slime-edit-definition name 'window)) + +(defun slime-edit-definition-other-frame (name) + "Like `slime-edit-definition' but switch to the other window." + (interactive (list (slime-read-symbol-name "Symbol: "))) + (slime-edit-definition name 'frame)) + +(defun slime-edit-definition-with-etags (name) + (interactive (list (slime-read-symbol-name "Symbol: "))) + (let ((tagdefs (slime-etags-definitions name))) + (cond (tagdefs + (message "Using tag file...") + (slime-goto-definition name tagdefs)) + (t + (error "No known definition for: %s" name))))) + +(defun slime-etags-definitions (name) + "Search definitions matching NAME in the tags file. +The result is a (possibly empty) list of definitions." + (require 'etags) + (let ((defs '())) + (save-excursion + (let ((first-time t)) + (while (visit-tags-table-buffer (not first-time)) + (setq first-time nil) + (goto-char (point-min)) + (while (search-forward name nil t) + (beginning-of-line) + (destructuring-bind (hint line &rest pos) (etags-snarf-tag) + (unless (eq hint t) ; hint==t if we are in a filename line + (let ((file (expand-file-name (file-of-tag)))) + (let ((loc `(:location (:file ,file) + (:line ,line) + (:snippet ,hint)))) + (push (list hint loc) defs)))))))) + (reverse defs)))) + +(defun slime-show-definitions (name definitions) + (slime-show-xrefs + `((,name . ,(loop for (dspec location) in definitions + collect (cons dspec location)))) + 'definition + name + (slime-current-package))) + +;;;;; first-change-hook + +(defun slime-first-change-hook () + "Notify Lisp that a source file's buffer has been modified." + ;; Be careful not to disturb anything! + ;; In particular if we muck up the match-data then query-replace + ;; breaks. -luke (26/Jul/2004) + (save-excursion + (save-match-data + (when (and (buffer-file-name) + (file-exists-p (buffer-file-name)) + (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) + 'slime-first-change-hook)) + +(add-hook 'slime-mode-hook 'slime-setup-first-change-hook) + + +;;;; Eval for Lisp + +(defun slime-eval-for-lisp (thread tag form-string) + (let ((ok nil) + (value nil) + (c (slime-connection))) + (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) 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 "slime-eval-in-emacs disabled for security. Set slime-enable-evaluate-in-emacs true to enable it."))) + + +;;;; `ED' + +(defvar slime-ed-frame nil + "The frame used by `slime-ed'.") + +(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. + +WHAT can be: + A filename (string), + A list (FILENAME LINE [COLUMN]), + A list (FILENAME :charpos CHARPOS), + A function name (symbol or cons), + nil. + +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 + (when slime-ed-use-dedicated-frame + (unless (and slime-ed-frame (frame-live-p slime-ed-frame)) + (setq slime-ed-frame (make-frame))) + (select-frame slime-ed-frame)) + (cond ((stringp what) + (find-file (slime-from-lisp-filename what))) + ((and (consp what) (stringp (first what))) + (find-file (first (slime-from-lisp-filename what))) + (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 + + +;;;; Interactive evaluation. + +(defun slime-interactive-eval (string) + "Read and evaluate STRING and print value in minibuffer. + +Note: If a prefix argument is in effect then the result will be +inserted in the current buffer." + (interactive (list (slime-read-from-minibuffer "Slime Eval: "))) + (slime-insert-transcript-delimiter string) + (cond ((not current-prefix-arg) + (slime-eval-with-transcript `(swank:interactive-eval ,string) + 'slime-display-eval-result)) + (t + (slime-eval-print string)))) + +(defun slime-display-eval-result (value) + (slime-message "%s" value)) + +(defun slime-eval-print (string) + "Eval STRING in Lisp; insert any output and the result at point." + (slime-eval-async `(swank:eval-and-grab-output ,string) + (lexical-let ((buffer (current-buffer))) + (lambda (result) + (with-current-buffer buffer + (destructuring-bind (output value) result + (insert output value))))))) + +(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))) + (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)))))))) + +(defun slime-eval-describe (form) + "Evaluate FORM in Lisp and display the result in a new buffer." + (lexical-let ((package (slime-current-package))) + (slime-eval-with-transcript + form (lambda (string) (slime-show-description string package))))) + +(defun slime-insert-transcript-delimiter (string) + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (unless (bolp) (insert-before-markers "\n")) + (slime-propertize-region '(slime-transcript-delimiter t) + (insert-before-markers + ";;;; " (subst-char-in-string ?\n ?\ + (substring string 0 + (min 60 (length string)))) + " ...\n"))))) + +(defun slime-display-buffer-region (buffer start end &optional other-window) + "Like `display-buffer', but only display the specified region." + (let ((window-min-height 1)) + (with-current-buffer buffer + (save-excursion + (save-restriction + (goto-char start) + (beginning-of-line) + (narrow-to-region (point) end) + (let ((window (display-buffer buffer other-window t))) + (set-window-start window (point)) + (unless (or (one-window-p t) + (/= (frame-width) (window-width))) + (set-window-text-height window (/ (1- (frame-height)) 2))) + (shrink-window-if-larger-than-buffer window) + window)))))) + +(defun slime-last-expression () + (buffer-substring-no-properties + (save-excursion (backward-sexp) (point)) + (point))) + +(defun slime-eval-last-expression () + "Evaluate the expression preceding point." + (interactive) + (slime-interactive-eval (slime-last-expression))) + +(defun slime-eval-last-expression-display-output () + "Display output buffer and evaluate the expression preceding point." + (interactive) + (slime-display-output-buffer) + (slime-interactive-eval (slime-last-expression))) + +(defun slime-eval-defun () + "Evaluate the current toplevel form. +Use `slime-re-evaluate-defvar' if the from starts with '(defvar'" + (interactive) + (let ((form (slime-defun-at-point))) + (cond ((string-match "^(defvar " form) + (slime-re-evaluate-defvar form)) + (t + (slime-interactive-eval form))))) + +(defun slime-eval-region (start end) + "Evaluate region." + (interactive "r") + (slime-eval-with-transcript + `(swank:interactive-eval-region + ,(buffer-substring-no-properties start end)))) + +(defun slime-eval-buffer () + "Evaluate the current buffer. +The value is printed in the echo area." + (interactive) + (slime-eval-region (point-min) (point-max))) + +(defun slime-re-evaluate-defvar (form) + "Force the re-evaluaton of the defvar form before point. + +First make the variable unbound, then evaluate the entire form." + (interactive (list (slime-last-expression))) + (slime-eval-with-transcript `(swank:re-evaluate-defvar ,form))) + +(defun slime-pprint-eval-last-expression () + "Evaluate the form before point; pprint the value in a buffer." + (interactive) + (slime-eval-describe `(swank:pprint-eval ,(slime-last-expression)))) + +(defun slime-eval-print-last-expression (string) + "Evaluate sexp before point; print value into the current buffer" + (interactive (list (slime-last-expression))) + (insert "\n") + (slime-eval-print string)) + +(defun slime-call-defun () + "Insert a call to the function defined around point into the REPL." + (interactive) + (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) + (save-excursion (insert ")"))))) + +;;;; Edit Lisp value +;;; +(defun slime-edit-value (form-string) + "\<slime-edit-value-mode-map>\ +Edit the value of a setf'able form in a new buffer. +The value is inserted into a temporary buffer for editing and then set +in Lisp when committed with \[slime-edit-value-commit]." + (interactive + (list (slime-read-from-minibuffer "Edit value (evaluated): " + (slime-sexp-at-point)))) + (slime-eval-async `(swank:value-for-editing ,form-string) + (lexical-let ((form-string form-string) + (package (slime-current-package))) + (lambda (result) + (slime-edit-value-callback form-string result + package))))) + +(make-variable-buffer-local + (defvar slime-edit-form-string nil + "The form being edited by `slime-edit-value'.")) + +(define-minor-mode slime-edit-value-mode + "Mode for editing a Lisp value." + nil + " edit" + '(("\C-c\C-c" . slime-edit-value-commit))) + +(defun slime-edit-value-callback (form-string current-value package) + (let ((name (generate-new-buffer-name (format "*Edit %s*" form-string)))) + (with-current-buffer (slime-get-temp-buffer-create name :mode 'lisp-mode) + (slime-mode 1) + (slime-temp-buffer-mode -1) ; don't want binding of 'q' + (slime-edit-value-mode 1) + (setq slime-edit-form-string form-string) + (setq slime-buffer-connection (slime-connection)) + (setq slime-buffer-package package) + (insert current-value)))) + +(defun slime-edit-value-commit () + "Commit the edited value to the Lisp image. +\(See `slime-edit-value'.)" + (interactive) + (if (null slime-edit-form-string) + (error "Not editing a value.") + (let ((value (buffer-substring-no-properties (point-min) (point-max)))) + (lexical-let ((buffer (current-buffer))) + (slime-eval-async `(swank:commit-edited-value ,slime-edit-form-string + ,value) + (lambda (_) + (with-current-buffer buffer + (slime-temp-buffer-quit t)))))))) + +;;;; Tracing + +(defun slime-redirect-trace-output () + "Redirect the trace output to a separate Emacs buffer." + (interactive) + (let ((buffer (get-buffer-create "*SLIME Trace Output*"))) + (with-current-buffer buffer + (let ((marker (copy-marker (buffer-size))) + (target (incf slime-last-output-target-id))) + (puthash target marker slime-output-target-to-marker) + (slime-eval `(swank:redirect-trace-output ,target)))) + ;; Note: We would like the entries in + ;; slime-output-target-to-marker to disappear when the buffers are + ;; killed. We cannot just make the hash-table ":weakness 'value" + ;; -- there is no reference from the buffers to the markers in the + ;; buffer, so entries would disappear even though the buffers are + ;; alive. Best solution might be to make buffer-local variables + ;; that keep the markers. --mkoeppe + (pop-to-buffer buffer))) + +(defun slime-untrace-all () + "Untrace all functions." + (interactive) + (slime-eval `(swank:untrace-all))) + +(defun slime-toggle-trace-fdefinition (&optional using-context-p) + "Toggle trace." + (interactive "P") + (let* ((spec (if using-context-p + (slime-extract-context) + (slime-symbol-name-at-point))) + (spec (slime-trace-query spec))) + (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec))))) + +(defun slime-trace-query (spec) + "Ask the user which function to trace; SPEC is the default. +The result is a string." + (cond ((null spec) + (slime-read-from-minibuffer "(Un)trace: ")) + ((stringp spec) + (slime-read-from-minibuffer "(Un)trace: " spec)) + (t + (destructure-case spec + ((setf n) + (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) + (((:defun :defmacro) n) + (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n))) + ((:defgeneric n) + (let* ((name (prin1-to-string n)) + (answer (slime-read-from-minibuffer "(Un)trace: " name))) + (cond ((and (string= name answer) + (y-or-n-p (concat "(Un)trace also all " + "methods implementing " + name "? "))) + (prin1-to-string `(:defgeneric ,n))) + (t + answer)))) + ((:defmethod &rest _) + (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) + ((:call caller callee) + (let* ((callerstr (prin1-to-string caller)) + (calleestr (prin1-to-string callee)) + (answer (slime-read-from-minibuffer "(Un)trace: " + calleestr))) + (cond ((and (string= calleestr answer) + (y-or-n-p (concat "(Un)trace only when " calleestr + " is called by " callerstr "? "))) + (prin1-to-string `(:call ,caller ,callee))) + (t + answer)))) + (((:labels :flet) &rest _) + (slime-read-from-minibuffer "(Un)trace local function: " + (prin1-to-string spec))))))) + +(defun slime-extract-context () + "Parse the context for the symbol at point. +Nil is returned if there's no symbol at point. Otherwise we detect +the following cases (the . shows the point position): + + (defun n.ame (...) ...) -> (:defun name) + (defun (setf n.ame) (...) ...) -> (:defun (setf name)) + (defmethod n.ame (...) ...) -> (:defmethod name (...)) + (defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name) + (defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name) + (defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name) + (defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name)) + +For other contexts we return the symbol at point." + (let ((name (slime-symbol-name-at-point))) + (if name + (let ((symbol (read name))) + (or (progn ;;ignore-errors + (slime-parse-context symbol)) + symbol))))) + +(defun slime-parse-context (name) + (save-excursion + (cond ((slime-in-expression-p '(defun *)) `(:defun ,name)) + ((slime-in-expression-p '(defmacro *)) `(:defmacro ,name)) + ((slime-in-expression-p '(defgeneric *)) `(:defgeneric ,name)) + ((slime-in-expression-p '(setf *)) + ;;a setf-definition, but which? + (backward-up-list 1) + (slime-parse-context `(setf ,name))) + ((slime-in-expression-p '(defmethod *)) + (unless (looking-at "\s ") + (forward-sexp 1)) ; skip over the methodname + (let (qualifiers arglist) + (loop for e = (read (current-buffer)) + until (listp e) do (push e qualifiers) + finally (setq arglist e)) + `(:defmethod ,name ,@qualifiers + ,(slime-arglist-specializers arglist)))) + ((and (symbolp name) + (slime-in-expression-p `(,name))) + ;; looks like a regular call + (let ((toplevel (ignore-errors (slime-parse-toplevel-form)))) + (cond ((slime-in-expression-p `(setf (*))) ;a setf-call + (if toplevel + `(:call ,toplevel (setf ,name)) + `(setf ,name))) + ((not toplevel) + name) + ((slime-in-expression-p `(labels ((*)))) + `(:labels ,toplevel ,name)) + ((slime-in-expression-p `(flet ((*)))) + `(:flet ,toplevel ,name)) + (t + `(:call ,toplevel ,name))))) + (t + name)))) + +(defun slime-in-expression-p (pattern) + "A helper function to determine the current context. +The pattern can have the form: + pattern ::= () ;matches always + | (*) ;matches inside a list + | (<symbol> <pattern>) ;matches if the first element in + ; the current list is <symbol> and + ; if <pattern> matches. + | ((<pattern>)) ;matches if we are in a nested list." + (save-excursion + (let ((path (reverse (slime-pattern-path pattern)))) + (loop for p in path + always (ignore-errors + (etypecase p + (symbol (slime-beginning-of-list) + (eq (read (current-buffer)) p)) + (number (backward-up-list p) + t))))))) + +(defun slime-pattern-path (pattern) + ;; Compute the path to the * in the pattern to make matching + ;; easier. The path is a list of symbols and numbers. A number + ;; means "(down-list <n>)" and a symbol "(look-at <sym>)") + (if (null pattern) + '() + (etypecase (car pattern) + ((member *) '()) + (symbol (cons (car pattern) (slime-pattern-path (cdr pattern)))) + (cons (cons 1 (slime-pattern-path (car pattern))))))) + +(defun slime-beginning-of-list (&optional up) + "Move backward the the beginning of the current expression. +Point is placed before the first expression in the list." + (backward-up-list (or up 1)) + (down-list 1) + (skip-syntax-forward " ")) + +(defun slime-parse-toplevel-form () + (save-excursion + (beginning-of-defun) + (down-list 1) + (forward-sexp 1) + (slime-parse-context (read (current-buffer))))) + +(defun slime-arglist-specializers (arglist) + (cond ((or (null arglist) + (member (first arglist) '(&optional &key &rest &aux))) + (list)) + ((consp (first arglist)) + (cons (second (first arglist)) + (slime-arglist-specializers (rest arglist)))) + (t + (cons 't + (slime-arglist-specializers (rest arglist)))))) + +(defun slime-disassemble-symbol (symbol-name) + "Display the disassembly for SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "Disassemble: "))) + (slime-eval-describe `(swank:disassemble-symbol ,symbol-name))) + +(defun slime-undefine-function (symbol-name) + "Unbind the function slot of SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "fmakunbound: " t))) + (slime-eval-async `(swank:undefine-function ,symbol-name) + (lambda (result) (message "%s" result)))) + +(defun slime-load-file (filename) + "Load the Lisp file FILENAME." + (interactive (list + (read-file-name "Load file: " nil nil + nil (if (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 + +(defun slime-toggle-profile-fdefinition (fname-string) + "Toggle profiling for FNAME-STRING." + (interactive (list (slime-read-from-minibuffer + "(Un)Profile: " + (slime-symbol-name-at-point)))) + (slime-eval-async `(swank:toggle-profile-fdefinition ,fname-string) + (lambda (r) (message "%s" r)))) + +(defun slime-unprofile-all () + "Unprofile all functions." + (interactive) + (slime-eval-async '(swank:unprofile-all) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-report () + "Print profile report." + (interactive) + (slime-eval-with-transcript '(swank:profile-report))) + +(defun slime-profile-reset () + "Reset profile counters." + (interactive) + (slime-eval-async (slime-eval `(swank:profile-reset)) + (lambda (r) (message "%s" r)))) + +(defun slime-profiled-functions () + "Return list of names of currently profiled functions." + (interactive) + (slime-eval-async `(swank:profiled-functions) + (lambda (r) (message "%s" r)))) + +(defun slime-profile-package (package callers methods) + "Profile all functions in PACKAGE. +If CALLER is non-nil names have counts of the most common calling +functions recorded. +If METHODS is non-nil, profile all methods of all generic function +having names in the given package." + (interactive (list (slime-read-package-name "Package: ") + (y-or-n-p "Record the most common callers? ") + (y-or-n-p "Profile methods? "))) + (slime-eval-async `(swank:profile-package ,package ,callers ,methods) + (lambda (r) (message "%s" r)))) + + + +;;;; Documentation + +(defun slime-hyperspec-lookup (symbol-name) + "A wrapper for `hyperspec-lookup'" + (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)) + stripped-symbol + (completing-read + "Look up symbol in Common Lisp HyperSpec: " + common-lisp-hyperspec-symbols #'boundp + 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))) + +(defun slime-describe-symbol (symbol-name) + "Describe the symbol at point." + (interactive (list (slime-read-symbol-name "Describe symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe `(swank:describe-symbol ,symbol-name))) + +(defun slime-documentation (symbol-name) + "Display function- or symbol-documentation for SYMBOL-NAME." + (interactive (list (slime-read-symbol-name "Documentation for symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe + `(swank:documentation-symbol ,symbol-name "(not documented)"))) + +(defun slime-describe-function (symbol-name) + (interactive (list (slime-read-symbol-name "Describe symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (slime-eval-describe `(swank:describe-function ,symbol-name))) + +(defun slime-apropos-summary (string case-sensitive-p package only-external-p) + "Return a short description for the performed apropos search." + (concat (if case-sensitive-p "Case-sensitive " "") + "Apropos for " + (format "%S" string) + (if package (format " in package %S" package) "") + (if only-external-p " (external symbols only)" ""))) + +(defun slime-apropos (string &optional only-external-p package + case-sensitive-p) + "Show all bound symbols whose names match STRING, a regular expression." + (interactive + (if current-prefix-arg + (list (read-string "SLIME Apropos: ") + (y-or-n-p "External symbols only? ") + (let ((pkg (slime-read-package-name "Package: "))) + (if (string= pkg "") nil pkg)) + (y-or-n-p "Case-sensitive? ")) + (list (read-string "SLIME Apropos: ") t nil nil))) + (let ((buffer-package (or package (slime-current-package)))) + (slime-eval-async + `(swank:apropos-list-for-emacs ,string ,only-external-p + ,case-sensitive-p ',package) + (lexical-let ((string string) + (package buffer-package) + (summary (slime-apropos-summary string case-sensitive-p + package only-external-p))) + (lambda (r) (slime-show-apropos r string package summary)))))) + +(defun slime-apropos-all () + "Shortcut for (slime-apropos <pattern> nil nil)" + (interactive) + (slime-apropos (read-string "SLIME Apropos: ") nil nil)) + +(defun slime-apropos-package (package &optional internal) + "Show apropos listing for symbols in PACKAGE. +With prefix argument include internal symbols." + (interactive (list (let ((pkg (slime-read-package-name "Package: "))) + (if (string= pkg "") (slime-current-package) pkg)) + current-prefix-arg)) + (slime-apropos "" (not internal) package)) + +(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*" :mode apropos-mode) + package + (set-syntax-table lisp-mode-syntax-table) + (slime-mode t) + (if (boundp 'header-line-format) + (setq header-line-format summary) + (insert summary "\n\n")) + (slime-set-truncate-lines) + (slime-print-apropos plists)))) + +(defvar slime-apropos-label-properties + (progn + (require 'apropos) + (cond ((and (boundp 'apropos-label-properties) + (symbol-value 'apropos-label-properties))) + ((boundp 'apropos-label-face) + (etypecase (symbol-value 'apropos-label-face) + (symbol `(face ,(or (symbol-value 'apropos-label-face) + 'italic) + mouse-face highlight)) + (list (symbol-value 'apropos-label-face))))))) + +(eval-when-compile (require 'apropos)) + +(defun slime-print-apropos (plists) + (dolist (plist plists) + (let ((designator (plist-get plist :designator))) + (assert designator) + (slime-insert-propertized (list 'face apropos-symbol-face + 'item designator + 'action 'slime-describe-symbol) + designator)) + (terpri) + (let ((apropos-label-properties slime-apropos-label-properties)) + (loop for (prop namespace) + in '((:variable "Variable") + (:function "Function") + (:generic-function "Generic Function") + (:macro "Macro") + (:special-operator "Special Operator") + (:setf "Setf") + (:type "Type") + (:class "Class") + (:alien-type "Alien type") + (: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))) + (when value + (princ " ") + (slime-insert-propertized apropos-label-properties namespace) + (princ ": ") + (princ (etypecase value + (string value) + ((member :not-documented) "(not documented)"))) + (add-text-properties + start (point) + (list 'type prop 'action 'slime-call-describer + 'button t 'apropos-label namespace + 'item (plist-get plist :designator))) + (terpri))))))) + +(defun slime-call-describer (arg) + (let* ((pos (if (markerp arg) arg (point))) + (type (get-text-property pos 'type)) + (item (get-text-property pos 'item))) + (slime-eval-describe `(swank:describe-definition-for-emacs ,item ,type)))) + + +;;;; XREF: cross-referencing + +(defvar slime-xref-mode-map) +(defvar slime-xref-saved-emacs-snapshot nil + "Buffer local variable in xref windows.") + +(define-derived-mode slime-xref-mode lisp-mode "xref" + "slime-xref-mode: Major mode for cross-referencing. +\<slime-xref-mode-map>\ +The most important commands: +\[slime-xref-quit] - Dismiss buffer. +\[slime-show-xref] - Display referenced source and keep xref window. +\[slime-goto-xref] - Jump to referenced source and dismiss xref window. + +\{slime-xref-mode-map}" + (setq font-lock-defaults nil) + (setq delayed-mode-hooks nil) + (slime-mode -1)) + +(slime-define-keys slime-xref-mode-map + ((kbd "RET") 'slime-show-xref) + ("\C-m" 'slime-show-xref) + (" " 'slime-goto-xref) + ("q" 'slime-xref-quit) + ("n" 'slime-next-line/not-add-newlines) + ("p" 'previous-line)) + +(defun slime-next-line/not-add-newlines () + (interactive) + (let ((next-line-add-newlines nil)) + (next-line 1))) + +;; FIXME: binding SLDB keys in xref buffer? -luke +(dolist (spec slime-keys) + (destructuring-bind (key command &key sldb prefixed &allow-other-keys) spec + (when sldb + (let ((key (if prefixed (concat slime-prefix-key key) key))) + (define-key slime-xref-mode-map key command))))) + + +;;;;; XREF results buffer and window management + +(defun slime-xref-buffer () + "Return the XREF results buffer. +If CREATE is non-nil, create it if necessary." + (or (find-if (lambda (b) (string-match "*XREF\[" (buffer-name b))) + (buffer-list)) + (error "No XREF buffer"))) + +(defun slime-init-xref-buffer (package ref-type symbol) + "Initialize the current buffer for displaying XREF information." + (slime-xref-mode) + (setq buffer-read-only nil) + (erase-buffer) + (setq slime-buffer-package package) + (slime-set-truncate-lines)) + +;; XXX: unused function +(defun slime-display-xref-buffer () + "Display the XREF results buffer in a window and select it." + (let* ((buffer (slime-xref-buffer)) + (window (get-buffer-window buffer))) + (if (and window (window-live-p window)) + (select-window window) + (select-window (display-buffer buffer t)) + (shrink-window-if-larger-than-buffer)))) + +(defmacro* slime-with-xref-buffer ((package ref-type symbol &key emacs-snapshot) + &body body) + "Execute BODY in a xref buffer, then show that buffer." + (let ((type (gensym "TYPE+")) (sym (gensym "SYM+")) + (pkg (gensym "PKG+")) (snapshot (gensym "SNAPSHOT+"))) + `(let ((,type ,ref-type) (,sym ,symbol) (,pkg ,package)) + ;; We don't want the the xref buffer to be the current buffer + ;; in the snapshot, so we gotta take the snapshot here. + (let ((,snapshot (or ,emacs-snapshot (slime-current-emacs-snapshot)))) + (with-current-buffer (get-buffer-create + (format "*XREF[%s: %s]*" ,type ,sym)) + (prog2 (progn + (slime-init-xref-buffer ,pkg ,type ,sym) + (make-local-variable 'slime-xref-saved-emacs-snapshot) + (setq slime-xref-saved-emacs-snapshot ,snapshot)) + (progn ,@body) + (setq buffer-read-only t) + (select-window (or (get-buffer-window (current-buffer) t) + (display-buffer (current-buffer) t))) + (shrink-window-if-larger-than-buffer))))))) + +(put 'slime-with-xref-buffer 'lisp-indent-function 1) + +(defun slime-insert-xrefs (xrefs) + "Insert XREFS in the current-buffer. +XREFS is a list of the form ((GROUP . ((LABEL . LOCATION) ...)) ...) +GROUP and LABEL are for decoration purposes. LOCATION is a source-location." + (unless (bobp) (insert "\n")) + (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 + (list 'slime-location location + 'face 'font-lock-keyword-face) + " " (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)) + +(defvar slime-next-location-function nil + "Function to call for going to the next location.") + +(defun slime-show-xrefs (xrefs type symbol package &optional emacs-snapshot) + "Show the results of an XREF query." + (if (null xrefs) + (message "No references found for %s." symbol) + (setq slime-next-location-function 'slime-goto-next-xref) + (slime-with-xref-buffer (package type symbol :emacs-snapshot emacs-snapshot) + (slime-insert-xrefs xrefs) + (goto-char (point-min)) + (forward-line) + (skip-chars-forward " \t")))) + + +;;;;; XREF commands + +(defun slime-who-calls (symbol) + "Show all known callers of the function SYMBOL." + (interactive (list (slime-read-symbol-name "Who calls: " t))) + (slime-xref :calls symbol)) + +(defun slime-calls-who (symbol) + "Show all known functions called by the function SYMBOL." + (interactive (list (slime-read-symbol-name "Who calls: " t))) + (slime-xref :calls-who symbol)) + +(defun slime-who-references (symbol) + "Show all known referrers of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who references: " t))) + (slime-xref :references symbol)) + +(defun slime-who-binds (symbol) + "Show all known binders of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who binds: " t))) + (slime-xref :binds symbol)) + +(defun slime-who-sets (symbol) + "Show all known setters of the global variable SYMBOL." + (interactive (list (slime-read-symbol-name "Who sets: " t))) + (slime-xref :sets symbol)) + +(defun slime-who-macroexpands (symbol) + "Show all known expanders of the macro SYMBOL." + (interactive (list (slime-read-symbol-name "Who macroexpands: " t))) + (slime-xref :macroexpands symbol)) + +(defun slime-who-specializes (symbol) + "Show all known methods specialized on class SYMBOL." + (interactive (list (slime-read-symbol-name "Who specializes: " t))) + (slime-xref :specializes symbol)) + +(defun slime-list-callers (symbol-name) + "List the callers of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callers: "))) + (slime-xref :callers symbol-name)) + +(defun slime-list-callees (symbol-name) + "List the callees of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callees: "))) + (slime-xref :callees symbol-name)) + +(defun slime-xref (type symbol) + "Make an XREF request to Lisp." + (slime-eval-async + `(swank:xref ',type ',symbol) + (lexical-let ((type type) + (symbol symbol) + (package (slime-current-package)) + ;; We have to take the snapshot here, because SLIME-EVAL-ASYNC + ;; is invoking its continuation within the extent of a different + ;; buffer. (2007-08-14) + (snapshot (slime-current-emacs-snapshot))) + (lambda (result) + (slime-show-xrefs result type symbol package snapshot))))) + + +;;;;; XREF navigation + +(defun slime-xref-location-at-point () + (save-excursion + ;; When the end of the last line is at (point-max) we can't find + ;; the text property there. Going to bol avoids this problem. + (beginning-of-line 1) + (or (get-text-property (point) 'slime-location) + (error "No reference at point.")))) + +(defun slime-goto-xref () + "Goto the cross-referenced location at point." + (interactive) + (let ((location (slime-xref-location-at-point))) + (slime-xref-cleanup) + (slime-goto-source-location location) + (switch-to-buffer (current-buffer)))) + +(defun slime-show-xref () + "Display the xref at point in the other window." + (interactive) + (let ((location (slime-xref-location-at-point))) + (slime-show-source-location location))) + +(defun slime-goto-next-xref () + "Goto the next cross-reference location." + (let ((location (with-current-buffer (slime-xref-buffer) + (let ((w (display-buffer (current-buffer) t))) + (goto-char (1+ (next-single-char-property-change + (point) 'slime-location))) + (set-window-point w (point))) + (cond ((eobp) + (message "No more xrefs.") + nil) + (t + (slime-xref-location-at-point)))))) + (when location + (slime-goto-source-location location) + (switch-to-buffer (current-buffer))))) + +(defun slime-next-location () + "Go to the next location, depending on context. +When displaying XREF information, this goes to the next reference." + (interactive) + (when (null slime-next-location-function) + (error "No context for finding locations.")) + (funcall slime-next-location-function)) + +(defun slime-xref-quit () + "Kill the current xref buffer and restore the window configuration." + (interactive) + (let ((snapshot slime-xref-saved-emacs-snapshot)) + (slime-xref-cleanup) + (slime-set-emacs-snapshot snapshot))) + +(defun slime-xref-cleanup () + "Delete overlays created by xref mode and kill the xref buffer." + (sldb-delete-overlays) + (let ((buffer (current-buffer))) + (delete-windows-on buffer) + (kill-buffer buffer))) + + +;;;; Macroexpansion + +(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 (fboundp 'slime-remove-edits) + (slime-remove-edits (point-min) (point-max))) + (undo arg))))) + +(defun slime-sexp-at-point-for-macroexpansion () + "Essentially like SLIME-SEXP-AT-POINT-OR-ERROR, but behaves a +bit more sanely in situations like ,(loop ...) where you want to +expand the LOOP form. See comment in the source of this function." + (let ((string (slime-sexp-at-point-or-error)) + (bounds (bounds-of-thing-at-point 'sexp)) + (char-at-point (substring-no-properties (thing-at-point 'char)))) + ;; SLIME-SEXP-AT-POINT(-OR-ERROR) uses (THING-AT-POINT 'SEXP) + ;; which is quite a bit botched: it returns "'(FOO BAR BAZ)" even + ;; when point is placed _at the opening parenthesis_, and hence + ;; "(FOO BAR BAZ)" wouldn't get expanded. Likewise for ",(...)", + ;; ",@(...)" (would return "@(...)"!!), and ""(...)". + ;; So we better fix this up here: + (when (string= char-at-point "(") + (let ((char0 (elt string 0))) + (when (member char0 '(?' ?, ?" ?@)) + (setf string (substring string 1)) + (incf (car bounds))))) + (list string bounds))) + +(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 (first (slime-sexp-at-point-for-macroexpansion)))) + (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) + (destructuring-bind (string bounds) + (slime-sexp-at-point-for-macroexpansion) + (lexical-let* ((start (car bounds)) + (end (cdr bounds)) + (point (point)) + (package (slime-current-package)) + (buffer (current-buffer))) + (slime-eval-async + `(,expander ,string) + (lambda (expansion) + (with-current-buffer buffer + (let ((buffer-read-only nil)) + (when (fboundp 'slime-remove-edits) + (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 +CL:MACROEXPAND." + (interactive "P") + (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) + (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.")) + +(defun slime-quit-lisp (&optional keep-buffers) + "Quit lisp, kill the inferior process and associated buffers." + (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) + (assert (process-status process) 'closed) + (let* ((inferior (slime-inferior-process process)) + (inferior-buffer (if inferior (process-buffer inferior)))) + (when inferior (delete-process inferior)) + (when inferior-buffer (kill-buffer inferior-buffer)) + (slime-net-close process) + (message "Connection closed."))) + +(defun slime-set-package (package) + (interactive (list (slime-read-package-name "Package: " + (slime-find-buffer-package)))) + (message "*package*: %s" (slime-eval `(swank:set-package ,package)))) + +(defun slime-set-default-directory (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 + (slime-eval `(swank:set-default-directory + ,(slime-to-lisp-filename directory))))) + (with-current-buffer (slime-output-buffer) + (setq default-directory (expand-file-name directory)))) + +(defun slime-sync-package-and-default-directory () + "Set Lisp's package and directory to the values in current buffer." + (interactive) + (let ((package (slime-eval `(swank:set-package + ,(slime-find-buffer-package)))) + (directory (slime-from-lisp-filename + (slime-eval `(swank:set-default-directory + ,(slime-to-lisp-filename + default-directory)))))) + (let ((dir default-directory)) + ;; Sync REPL dir + (with-current-buffer (slime-output-buffer) + (setq default-directory dir)) + ;; Sync *inferior-lisp* dir + (let* ((proc (slime-process)) + (buffer (and proc (process-buffer proc)))) + (when buffer + (with-current-buffer buffer + (setq default-directory dir))))) + (message "package: %s default-directory: %s" (car package) directory))) + + +;;;; Debugger (SLDB) + +(defvar sldb-hook nil + "Hook run on entry to the debugger.") + + +;;;;; Local variables in the debugger buffer + +(slime-make-variables-buffer-local + (defvar sldb-condition nil + "A list (DESCRIPTION TYPE) describing the condition being debugged.") + + (defvar sldb-saved-window-configuration nil + "Window configuration before the debugger was initially entered.") + + (defvar sldb-restarts nil + "List of (NAME DESCRIPTION) for each available restart.") + + (defvar sldb-level nil + "Current debug level (recursion depth) displayed in buffer.") + + (defvar sldb-backtrace-start-marker nil + "Marker placed at the beginning of the backtrace text.") + + (defvar sldb-continuations nil + "List of ids for pending continuation.")) + +;;;;; SLDB macros + +;; some macros that we need to define before the first use + +(defmacro in-sldb-face (name string) + "Return STRING propertised with face sldb-NAME-face." + (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))) + (var (gensym "string"))) + `(let ((,var ,string)) + (slime-add-face ',facename ,var) + ,var))) + +(put 'in-sldb-face 'lisp-indent-function 1) + +(defun slime-add-face (face string) + (add-text-properties 0 (length string) (list 'face face) string) + string) + + +;;;;; 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> + +Commands to examine the selected frame: + \[sldb-toggle-details] - toggle details (local bindings, CATCH tags) + \[sldb-show-source] - view source for the frame + \[sldb-eval-in-frame] - eval in frame + \[sldb-pprint-eval-in-frame] - eval in frame, pretty-print result + \[sldb-disassemble] - disassemble + \[sldb-inspect-in-frame] - inspect + +Commands to invoke restarts: + \[sldb-quit] - quit + \[sldb-abort] - abort + \[sldb-continue] - continue + \[sldb-invoke-restart-0]-\[sldb-invoke-restart-9] - restart shortcuts + +Commands to navigate frames: + \[sldb-down] - down + \[sldb-up] - up + \[sldb-details-down] - down, with details + \[sldb-details-up] - up, with details + +Miscellaneous commands: + \[sldb-restart-frame] - restart frame + \[sldb-return-from-frame] - return from frame + \[sldb-step] - step + \[sldb-break-with-default-debugger] - switch to default debugger + \[slime-interactive-eval] - eval + +Full list of commands: + +\{sldb-mode-map}" + (erase-buffer) + (set-syntax-table sldb-mode-syntax-table) + (slime-set-truncate-lines) + ;; Make original slime-connection "sticky" for SLDB commands in this buffer + (setq slime-buffer-connection (slime-connection)) + (add-local-hook 'kill-buffer-hook 'sldb-delete-overlays)) + +(slime-define-keys sldb-mode-map + ("h" 'describe-mode) + ("v" 'sldb-show-source) + ((kbd "RET") 'sldb-default-action) + ("\C-m" 'sldb-default-action) + ([mouse-2] 'sldb-default-action/mouse) + ([follow-link] 'mouse-face) + ("e" 'sldb-eval-in-frame) + ("d" 'sldb-pprint-eval-in-frame) + ("D" 'sldb-disassemble) + ("i" 'sldb-inspect-in-frame) + ("n" 'sldb-down) + ("p" 'sldb-up) + ("\M-n" 'sldb-details-down) + ("\M-p" 'sldb-details-up) + ("<" 'sldb-beginning-of-backtrace) + (">" 'sldb-end-of-backtrace) + ("t" 'sldb-toggle-details) + ("r" 'sldb-restart-frame) + ("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) + ("B" 'sldb-break-with-default-debugger) + ("P" 'sldb-print-condition) + ("C" 'sldb-inspect-condition) + (":" 'slime-interactive-eval) + ("\C-c\C-d" slime-doc-map)) + +;; Inherit bindings from slime-mode +(dolist (spec slime-keys) + (destructuring-bind (key command &key sldb prefixed &allow-other-keys) spec + (when sldb + (let ((key (if prefixed (concat slime-prefix-key key) key))) + (define-key sldb-mode-map key command))))) + +;; Keys 0-9 are shortcuts to invoke particular restarts. +(defmacro define-sldb-invoke-restart-key (number key) + (let ((fname (intern (format "sldb-invoke-restart-%S" number))) + (docstring (format "Invoke restart numbered %S." number))) + `(progn + (defun ,fname () + ,docstring + (interactive) + (sldb-invoke-restart ,number)) + (define-key sldb-mode-map ,key ',fname)))) + +(defmacro define-sldb-invoke-restart-keys (from to) + `(progn + ,@(loop for n from from to to + collect `(define-sldb-invoke-restart-key ,n + ,(number-to-string n))))) + +(define-sldb-invoke-restart-keys 0 9) + + +;;;;; SLDB buffer creation & update + +(defun sldb-buffers () + "Return a list of all sldb buffers." + (slime-filter-buffers (lambda () (eq major-mode 'sldb-mode)))) + +(defun sldb-find-buffer (thread &optional connection) + (let ((connection (or connection (slime-connection)))) + (find-if (lambda (buffer) + (with-current-buffer buffer + (and (eq slime-buffer-connection connection) + (eq slime-current-thread thread)))) + (sldb-buffers)))) + +(defun sldb-get-default-buffer () + "Get a sldb buffer. +The buffer is chosen more or less randomly." + (car (sldb-buffers))) + +(defun sldb-get-buffer (thread &optional connection) + "Find or create a sldb-buffer for THREAD." + (let ((connection (or connection (slime-connection)))) + (or (sldb-find-buffer thread connection) + (let ((name (format "*sldb %s/%s*" (slime-connection-name) thread))) + (with-current-buffer (generate-new-buffer name) + (setq slime-buffer-connection connection + slime-current-thread thread) + (current-buffer)))))) + +(defun sldb-debugged-continuations (connection) + "Return the debugged continuations for CONNECTION." + (lexical-let ((accu '())) + (dolist (b (sldb-buffers)) + (with-current-buffer b + (when (eq slime-buffer-connection connection) + (setq accu (append sldb-continuations accu))))) + accu)) + +(defun sldb-setup (thread level condition restarts frames conts) + "Setup a new SLDB buffer. +CONDITION is a string describing the condition to debug. +RESTARTS is a list of strings (NAME DESCRIPTION) for each available restart. +FRAMES is a list (NUMBER DESCRIPTION) describing the initial +portion of the backtrace. Frames are numbered from 0. +CONTS is a list of pending Emacs continuations." + (with-current-buffer (sldb-get-buffer thread) + (unless (equal sldb-level level) + (setq buffer-read-only nil) + (sldb-mode) + (unless sldb-saved-window-configuration + (setq sldb-saved-window-configuration (current-window-configuration))) + (setq slime-current-thread thread) + (setq sldb-level level) + (setq mode-name (format "sldb[%d]" sldb-level)) + (setq sldb-condition condition) + (setq sldb-restarts restarts) + (setq sldb-continuations conts) + (sldb-insert-condition condition) + (insert "\n\n" (in-sldb-face section "Restarts:") "\n") + (sldb-insert-restarts restarts) + (insert "\n" (in-sldb-face section "Backtrace:") "\n") + (setq sldb-backtrace-start-marker (point-marker)) + (save-excursion + (sldb-insert-frames (sldb-prune-initial-frames frames) t)) + (run-hooks 'sldb-hook) + (pop-to-buffer (current-buffer)) + (sldb-recenter-region (point-min) (point)) + (setq buffer-read-only t) + (when (and slime-stack-eval-tags + ;; (y-or-n-p "Enter recursive edit? ") + ) + (message "Entering recursive edit..") + (recursive-edit))))) + +(defun sldb-activate (thread level) + "Display the debugger buffer for THREAD. +If LEVEL isn't the same as in the buffer, reinitialize the buffer." + (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) + "Exit from the debug level LEVEL." + (when-let (sldb (sldb-find-buffer thread)) + (with-current-buffer sldb + (unless stepping + (set-window-configuration sldb-saved-window-configuration)) + (let ((inhibit-read-only t)) + (erase-buffer)) + (setq sldb-level nil)) + (when (and (= level 1) (not stepping)) + (kill-buffer sldb)))) + +(defun sldb-insert-condition (condition) + "Insert the text for CONDITION. +CONDITION should be a list (MESSAGE TYPE EXTRAS). +EXTRAS is currently used for the stepper." + (destructuring-bind (message type 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" + (in-sldb-face condition type)) + (sldb-dispatch-extras extras))) + +(defvar sldb-extras-hooks) + +(defun sldb-dispatch-extras (extras) + ;; this is (mis-)used for the stepper + (dolist (extra extras) + (destructure-case extra + ((:show-frame-source n) + (sldb-show-frame-source n)) + (t + (or (run-hook-with-args-until-success 'sldb-extras-hooks extra) + ;;(error "Unhandled extra element:" extra) + ))))) + +(defun sldb-insert-restarts (restarts) + "Insert RESTARTS and add the needed text props +RESTARTS should be alist ((NAME DESCRIPTION) ...)." + (loop for (name string) in restarts + for number from 0 do + (insert " ") + (slime-insert-propertized + `(,@nil restart-number ,number + sldb-default-action sldb-invoke-restart + mouse-face highlight) + (in-sldb-face restart-number (number-to-string number)) + ": [" (in-sldb-face restart-type name) "] " + (in-sldb-face restart string)) + (insert "\n"))) + +(defun sldb-prune-initial-frames (frames) + "Return the prefix of FRAMES to initially present to the user. +Regexp heuristics are used to avoid showing SWANK-internal frames." + (let* ((case-fold-search t) + (rx "^\([() ]\|lambda\)*swank\>")) + (or (loop for frame in frames + for (_ string) = frame + until (string-match rx string) + collect frame) + frames))) + +(defun sldb-insert-frames (frames more) + "Insert FRAMES into buffer. +If MORE is non-nil, more frames are on the Lisp stack." + (mapc #'sldb-insert-frame frames) + (when more + (destructuring-bind ((num _)) (last frames) + (slime-insert-propertized + `(,@nil sldb-default-action sldb-fetch-more-frames + sldb-previous-frame-number ,num + point-entered sldb-fetch-more-frames + start-open t + face sldb-section-face + mouse-face highlight) + " --more--") + (insert "\n")))) + +(defun sldb-insert-frame (frame &optional face) + "Insert FRAME with FACE at point. +If FACE is nil use `sldb-frame-line-face'." + (destructuring-bind (number string) frame + (let ((props `(frame ,frame sldb-default-action sldb-toggle-details))) + (slime-propertize-region props + (slime-propertize-region '(mouse-face highlight) + (insert " " (in-sldb-face frame-label (format "%2d:" number)) " ") + (slime-insert-indented + (slime-add-face (or face 'sldb-frame-line-face) + string))) + (insert "\n"))))) + +(defun sldb-fetch-more-frames (&rest ignore) + "Fetch more backtrace frames. +Called on the `point-entered' text-property hook." + (let ((inhibit-point-motion-hooks t) + (inhibit-read-only t) + (prev (get-text-property (point) 'sldb-previous-frame-number))) + ;; for unkown reasons, PREV is sometimes nil + (when prev + (let* ((count 40) + (from (1+ prev)) + (to (+ from count)) + (frames (slime-eval `(swank:backtrace ,from ,to))) + (more (slime-length= frames count)) + (pos (point))) + (delete-region (line-beginning-position) (point-max)) + (sldb-insert-frames frames more) + (goto-char pos))))) + + +;;;;;; SLDB examining text props + +(defun sldb-restart-at-point () + (or (get-text-property (point) 'restart-number) + (error "No restart at point"))) + +(defun sldb-frame-number-at-point () + (let ((frame (get-text-property (point) 'frame))) + (cond (frame (car frame)) + (t (error "No frame at point"))))) + +(defun sldb-var-number-at-point () + (let ((var (get-text-property (point) 'var))) + (cond (var var) + (t (error "No variable at point"))))) + +(defun sldb-previous-frame-number () + (save-excursion + (sldb-backward-frame) + (sldb-frame-number-at-point))) + +(defun sldb-frame-details-visible-p () + (and (get-text-property (point) 'frame) + (get-text-property (point) 'details-visible-p))) + +(defun sldb-frame-region () + (save-excursion + (goto-char (next-single-property-change (point) 'frame nil (point-max))) + (backward-char) + (values (previous-single-property-change (point) 'frame) + (next-single-property-change (point) 'frame nil (point-max))))) + +(defun sldb-forward-frame () + (goto-char (next-single-char-property-change (point) 'frame))) + +(defun sldb-backward-frame () + (goto-char (previous-single-char-property-change + (car (sldb-frame-region)) + 'frame + nil sldb-backtrace-start-marker))) + +(defun sldb-goto-last-frame () + (goto-char (point-max)) + (while (not (get-text-property (point) 'frame)) + (goto-char (previous-single-property-change (point) 'frame)))) + +(defun sldb-beginning-of-backtrace () + "Goto the first frame." + (interactive) + (goto-char sldb-backtrace-start-marker)) + + +;;;;;; SLDB recenter & redisplay + +;; FIXME: these functions need factorization + +(defvar sldb-show-location-recenter-arg nil + "Argument to pass to `recenter' when displaying a source location.") + +(defun slime-show-buffer-position (position) + "Ensure sure that the POSITION in the current buffer is visible." + (save-selected-window + (let ((w (select-window (or (get-buffer-window (current-buffer) t) + (display-buffer (current-buffer) t))))) + (goto-char position) + (push-mark) + (unless (pos-visible-in-window-p) + (slime-recenter-window w sldb-show-location-recenter-arg))))) + +(defun slime-recenter-window (window line) + "Set window-start in WINDOW LINE lines before point." + (let* ((line (if (not line) + (/ (window-height window) 2) + line)) + (start (save-excursion + (loop repeat line do (forward-line -1)) + (point)))) + (set-window-start window start))) + +(defun sldb-recenter-region (start end &optional center) + "Make the region from START to END visible. +Avoid point motions, if possible. +Minimize scrolling, if CENTER is nil. +If CENTER is true, scroll enough to center the region in the window." + (let ((pos (point)) (lines (count-screen-lines start end t))) + (assert (and (<= start pos) (<= pos end))) + ;;(sit-for 0) + (cond ((and (pos-visible-in-window-p start) + (pos-visible-in-window-p end))) + ((< lines (window-height)) + (cond (center (recenter (+ (/ (- (window-height) 1 lines) + 2) + (slime-count-lines start pos)))) + (t (recenter (+ (- (window-height) 1 lines) + (slime-count-lines start pos)))))) + (t + (goto-char start) + (recenter 0) + (cond ((pos-visible-in-window-p pos) + (goto-char pos)) + (t + (goto-char start) + (next-line (- (window-height) 2)))))))) + +;; not sure yet, whether this is a good idea. +(defmacro slime-save-coordinates (origin &rest body) + "Restore line and column relative to ORIGIN, after executing BODY. + +This is useful if BODY deletes and inserts some text but we want to +preserve the current row and column as closely as possible." + (let ((base (make-symbol "base")) + (goal (make-symbol "goal")) + (mark (make-symbol "mark"))) + `(let* ((,base ,origin) + (,goal (slime-coordinates ,base)) + (,mark (point-marker))) + (set-marker-insertion-type ,mark t) + (prog1 (save-excursion ,@body) + (slime-restore-coordinate ,base ,goal ,mark))))) + +(put 'slime-save-coordinates 'lisp-indent-function 1) + +(defun slime-coordinates (origin) + ;; Return a pair (X . Y) for the column and line distance to ORIGIN. + (let ((y (slime-count-lines origin (point))) + (x (save-excursion + (- (current-column) + (progn (goto-char origin) (current-column)))))) + (cons x y))) + +(defun slime-restore-coordinate (base goal limit) + ;; Move point to GOAL. Coordinates are relative to BASE. + ;; Don't move beyond LIMIT. + (save-restriction + (narrow-to-region base limit) + (goto-char (point-min)) + (let ((col (current-column))) + (forward-line (cdr goal)) + (when (and (eobp) (bolp) (not (bobp))) + (backward-char)) + (move-to-column (+ col (car goal)))))) + +(defun slime-count-lines (start end) + "Return the number of lines between START and END. +This is 0 if START and END at the same line." + (- (count-lines start end) + (if (save-excursion (goto-char end) (bolp)) 0 1))) + + +;;;;; SLDB commands + +(defun sldb-default-action () + "Invoke the action at point." + (interactive) + (let ((fn (get-text-property (point) 'sldb-default-action))) + (if fn (funcall fn)))) + +(defun sldb-default-action/mouse (event) + "Invoke the action pointed at by the mouse." + (interactive "e") + (destructuring-bind (mouse-1 (w pos &rest _)) event + (save-excursion + (goto-char pos) + (let ((fn (get-text-property (point) 'sldb-default-action))) + (if fn (funcall fn)))))) + +(defun sldb-end-of-backtrace () + "Fetch the entire backtrace and go to the last frame." + (interactive) + (sldb-fetch-all-frames) + (sldb-goto-last-frame)) + +(defun sldb-fetch-all-frames () + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (sldb-goto-last-frame) + (let ((last (sldb-frame-number-at-point))) + (goto-char (next-single-char-property-change (point) 'frame)) + (delete-region (point) (point-max)) + (save-excursion + (sldb-insert-frames (slime-eval `(swank:backtrace ,(1+ last) nil)) + nil))))) + + +;;;;;; SLDB show source + +(defvar sldb-overlays '() + "List of overlays created in source code buffers to highlight expressions.") + +(defun sldb-show-source () + "Highlight the frame at point's expression in a source code buffer." + (interactive) + (sldb-show-frame-source (sldb-frame-number-at-point))) + +(defun sldb-show-frame-source (frame-number) + (sldb-delete-overlays) + (slime-eval-async + `(swank:frame-source-location-for-emacs ,frame-number) + (lambda (source-location) + (destructure-case source-location + ((:error message) + (message "%s" message) + (ding)) + (t + (slime-show-source-location source-location)))))) + +(defun slime-show-source-location (source-location &optional no-highlight-p) + (slime-goto-source-location source-location) + (unless no-highlight-p (sldb-highlight-sexp)) + (slime-show-buffer-position (point))) + +(defun sldb-highlight-sexp (&optional start end) + "Highlight the first sexp after point." + (sldb-delete-overlays) + (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))) + +(defun sldb-delete-overlays () + (mapc #'delete-overlay sldb-overlays) + (setq sldb-overlays '())) + + +;;;;;; SLDB toggle details + +(defun sldb-toggle-details (&optional on) + "Toggle display of details for the current frame. +The details include local variable bindings and CATCH-tags." + (interactive) + (assert (sldb-frame-number-at-point)) + (let ((inhibit-read-only t)) + (if (or on (not (sldb-frame-details-visible-p))) + (sldb-show-frame-details) + (sldb-hide-frame-details)))) + +(defun sldb-show-frame-details () + ;; fetch and display info about local variables and catch tags + (destructuring-bind (start end frame locals catches) (sldb-frame-details) + (slime-save-coordinates start + (delete-region start end) + (slime-propertize-region `(frame ,frame details-visible-p t) + (sldb-insert-frame frame 'sldb-detailed-frame-line-face) + (let ((indent1 " ") + (indent2 " ")) + (insert indent1 (in-sldb-face section + (if locals "Locals:" "[No Locals]")) "\n") + (sldb-insert-locals locals indent2 frame) + (when catches + (insert indent1 (in-sldb-face section "Catch-tags:") "\n") + (dolist (tag catches) + (slime-propertize-region `(catch-tag ,tag) + (insert indent2 (in-sldb-face catch-tag (format "%s" tag)) + "\n")))) + (setq end (point))))) + (sldb-recenter-region start end))) + +(defun sldb-frame-details () + ;; Return a list (START END FRAME LOCALS CATCHES) for frame at point. + (let* ((frame (get-text-property (point) 'frame)) + (num (car frame)) + (catches (sldb-catch-tags num)) + (locals (sldb-frame-locals num))) + (destructuring-bind (start end) (sldb-frame-region) + (list start end frame locals catches)))) + +(defun sldb-insert-locals (vars prefix frame) + "Insert VARS and add PREFIX at the beginning of each inserted line. +VAR should be a plist with the keys :name, :id, and :value." + (loop for i from 0 + for var in vars do + (destructuring-bind (&key name id value) var + (slime-propertize-region (list 'sldb-default-action 'sldb-inspect-var + 'var i) + (insert prefix + (in-sldb-face local-name + (concat name (if (zerop id) "" (format "#%d" id)))) + " = ") + (insert (in-sldb-face local-value value) "\n"))))) + +(defun sldb-hide-frame-details () + ;; delete locals and catch tags, but keep the function name and args. + (destructuring-bind (start end) (sldb-frame-region) + (let ((frame (get-text-property (point) 'frame))) + (slime-save-coordinates start + (delete-region start end) + (slime-propertize-region '(details-visible-p nil) + (sldb-insert-frame frame)))))) + +(defun sldb-disassemble () + "Disassemble the code for the current frame." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-disassemble ,frame) + (lambda (result) + (slime-show-description result nil))))) + +(defun sldb-print-condition () + "Print the condition SLDB is handling in the REPL. +This way you can still see what the error was after exiting SLDB." + (interactive) + (unless sldb-condition + (error "No condition known (wrong buffer?)")) + (slime-write-string (format "%s\n%s\n" + (first sldb-condition) + (second sldb-condition)))) + +(defun sldb-frame-locals (frame) + (slime-eval `(swank:frame-locals-for-emacs ,frame))) + +(defun sldb-catch-tags (frame) + (slime-eval `(swank:frame-catch-tags-for-emacs ,frame))) + + +;;;;;; SLDB eval and inspect + +(defun sldb-eval-in-frame (string) + "Prompt for an expression and evaluate it in the selected frame." + (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) + (let* ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:eval-string-in-frame ,string ,number) + (if current-prefix-arg + 'slime-write-string + 'slime-display-eval-result)))) + +(defun sldb-pprint-eval-in-frame (string) + "Prompt for an expression, evaluate in selected frame, pretty-print result." + (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) + (let* ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:pprint-eval-string-in-frame ,string ,number) + (lambda (result) + (slime-show-description result nil))))) + + + +(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)))) + (let ((number (sldb-frame-number-at-point))) + (slime-eval-async `(swank:inspect-in-frame ,string ,number) + 'slime-open-inspector))) + +(defun sldb-inspect-var () + (let ((frame (sldb-frame-number-at-point)) + (var (sldb-var-number-at-point))) + (slime-eval-async `(swank:inspect-frame-var ,frame ,var) + 'slime-open-inspector))) + +(defun sldb-inspect-condition () + "Inspect the current debugger condition." + (interactive) + (slime-eval-async '(swank:inspect-current-condition) + 'slime-open-inspector)) + + +;;;;;; SLDB movement + +(defun sldb-down () + "Select next frame." + (interactive) + (sldb-forward-frame)) + +(defun sldb-up () + "Select previous frame." + (interactive) + (sldb-backward-frame) + (when (= (point) sldb-backtrace-start-marker) + (recenter (1+ (count-lines (point-min) (point)))))) + +(defun sldb-sugar-move (move-fn) + (let ((inhibit-read-only t)) + (when (sldb-frame-details-visible-p) (sldb-hide-frame-details)) + (funcall move-fn) + (sldb-show-source) + (sldb-toggle-details t))) + +(defun sldb-details-up () + "Select previous frame and show details." + (interactive) + (sldb-sugar-move 'sldb-up)) + +(defun sldb-details-down () + "Select next frame and show details." + (interactive) + (sldb-sugar-move 'sldb-down)) + + +;;;;;; SLDB restarts + +(defun sldb-quit () + "Quit to toplevel." + (interactive) + (slime-rex () ('(swank:throw-to-toplevel)) + ((:ok _) (error "sldb-quit returned")) + ((:abort)))) + +(defun sldb-continue () + "Invoke the "continue" restart." + (interactive) + (slime-rex () + ('(swank:sldb-continue)) + ((:ok _) + (message "No restart named continue") + (ding)) + ((:abort)))) + +(defun sldb-abort () + "Invoke the "abort" restart." + (interactive) + (slime-eval-async '(swank:sldb-abort) + (lambda (v) (message "Restart returned: %S" v)))) + +(defun sldb-invoke-restart (&optional number) + "Invoke a restart. +Optional NUMBER specifies the restart to invoke, otherwise +use the restart at point." + (interactive) + (let ((restart (or number (sldb-restart-at-point)))) + (slime-rex () + ((list 'swank:invoke-nth-restart-for-emacs sldb-level restart)) + ((:ok value) (message "Restart returned: %s" value)) + ((:abort))))) + +(defun sldb-break-with-default-debugger () + "Enter default debugger." + (interactive) + (slime-rex () + ('(swank:sldb-break-with-default-debugger) nil slime-current-thread) + ((:abort)))) + +(defun sldb-step () + "Select the "continue" restart and set a new break point." + (interactive) + (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." + (interactive) + (let ((frame (sldb-frame-number-at-point))) + (slime-eval-async `(swank:sldb-break-on-return ,frame) + (lambda (msg) (message "%s" msg))))) + +(defun sldb-break (name) + "Set a breakpoint at the start of the function NAME." + (interactive (list (slime-read-symbol-name "Function: " t))) + (slime-eval-async `(swank:sldb-break ,name) + (lambda (msg) (message "%s" msg)))) + +(defun sldb-return-from-frame (string) + "Reads an expression in the minibuffer and causes the function to +return that value, evaluated in the context of the frame." + (interactive (list (slime-read-from-minibuffer "Return from frame: "))) + (let* ((number (sldb-frame-number-at-point))) + (slime-rex () + ((list 'swank:sldb-return-from-frame number string)) + ((:ok value) (message "%s" value)) + ((:abort))))) + +(defun sldb-restart-frame () + "Causes the frame to restart execution with the same arguments as it +was called originally." + (interactive) + (let* ((number (sldb-frame-number-at-point))) + (slime-rex () + ((list 'swank:restart-frame number)) + ((:ok value) (message "%s" value)) + ((:abort))))) + + +;;;; Thread control panel + +(defun slime-list-threads () + "Display a list of threads." + (interactive) + (slime-eval-async + '(swank:list-threads) + (lambda (threads) + (with-current-buffer (get-buffer-create "*slime-threads*") + (slime-thread-control-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (loop for idx from 0 + for (name status id) in threads + do (slime-thread-insert idx name status id)) + (goto-char (point-min)) + (setq buffer-read-only t) + (pop-to-buffer (current-buffer))))))) + +(defun slime-thread-insert (idx name summary id) + (slime-propertize-region `(thread-id ,idx) + (insert (format "%3s: " id)) + (slime-insert-propertized '(face bold) name) + (insert-char ?\ (- 30 (current-column))) + (let ((summary-start (point))) + (insert " " summary) + (unless (bolp) (insert "\n")) + (indent-rigidly summary-start (point) 2)))) + + +;;;;; Major mode + +(define-derived-mode slime-thread-control-mode fundamental-mode + "thread-control" + "SLIME Thread Control Panel Mode. + +\{slime-thread-control-mode-map}" + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +(slime-define-keys slime-thread-control-mode-map + ("a" 'slime-thread-attach) + ("d" 'slime-thread-debug) + ("g" 'slime-list-threads) + ("k" 'slime-thread-kill) + ("q" 'slime-thread-quit)) + +(defun slime-thread-quit () + (interactive) + (slime-eval-async `(swank:quit-thread-browser)) + (kill-buffer (current-buffer))) + +(defun slime-thread-kill () + (interactive) + (let ((id (get-text-property (point) 'thread-id))) + (slime-eval `(swank:kill-nth-thread ,id))) + (call-interactively 'slime-list-threads)) + +(defun slime-thread-attach () + (interactive) + (let ((id (get-text-property (point) 'thread-id)) + (file (slime-swank-port-file))) + (slime-eval-async `(swank:start-swank-server-in-thread ,id ,file))) + (slime-read-port-and-connect nil nil)) + +(defun slime-thread-debug () + (interactive) + (let ((id (get-text-property (point) 'thread-id))) + (slime-eval-async `(swank:debug-nth-thread ,id)))) + + +;;;;; Connection listing + +(define-derived-mode slime-connection-list-mode fundamental-mode + "connection-list" + "SLIME Connection List Mode. + +\{slime-connection-list-mode-map}" + (when slime-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +(slime-define-keys slime-connection-list-mode-map + ((kbd "RET") 'slime-goto-connection) + ("d" 'slime-connection-list-make-default) + ("g" 'slime-update-connection-list) + ((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) + (error "No connection at point"))) + +(defun slime-goto-connection () + "Switch to the REPL buffer for the connection at point." + (interactive) + (let ((slime-dispatching-connection (slime-connection-at-point))) + (switch-to-buffer (slime-output-buffer)))) + +(defun slime-quit-connection-at-point (connection) + (interactive (list (slime-connection-at-point))) + (let ((slime-dispatching-connection connection)) + (slime-quit-lisp) + (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." + (interactive) + (slime-select-connection (slime-connection-at-point)) + (slime-update-connection-list)) + +(defun slime-list-connections () + "Display a list of all connections." + (interactive) + (when (get-buffer "*SLIME connections*") + (kill-buffer "*SLIME connections*")) + (with-current-buffer + (slime-get-temp-buffer-create "*SLIME connections*" + :mode 'slime-connection-list-mode) + (slime-draw-connection-list) + (setq buffer-read-only t) + (pop-to-buffer (current-buffer)))) + +(defun slime-update-connection-list () + "Display a list of all connections." + (interactive) + (let ((pos (point)) + (inhibit-read-only t)) + (erase-buffer) + (slime-draw-connection-list) + (goto-char pos))) + +(defun slime-draw-connection-list () + (let ((default-pos nil) + (default slime-default-connection) + (fstring "%s%2s %-10s %-17s %-7s %-s\n")) + (insert (format fstring " " "Nr" "Name" "Port" "Pid" "Type") + (format fstring " " "--" "----" "----" "---" "----")) + (dolist (p (reverse slime-net-processes)) + (when (eq default p) (setf default-pos (point))) + (slime-insert-propertized + (list 'slime-connection p) + (format fstring + (if (eq default p) "*" " ") + (slime-connection-number p) + (slime-connection-name p) + (or (process-id p) (process-contact p)) + (slime-pid p) + (slime-lisp-implementation-type p)))) + (when default + (goto-char default-pos)))) + + +;;;; Inspector + +(defgroup slime-inspector nil + "Inspector faces." + :prefix "slime-inspector-" + :group 'slime) + +(defface slime-inspector-topline-face + '((t ())) + "Face for top line describing object." + :group 'slime-inspector) + +(defface slime-inspector-label-face + '((t (:inherit font-lock-constant-face))) + "Face for labels in the inspector." + :group 'slime-inspector) + +(defface slime-inspector-value-face + (if (slime-face-inheritance-possible-p) + '((t (:inherit font-lock-builtin-face))) + '((((background light)) (:foreground "MediumBlue" :bold t)) + (((background dark)) (:foreground "LightGray" :bold t)))) + "Face for things which can themselves be inspected." + :group 'slime-inspector) + +(defface slime-inspector-action-face + (if (slime-face-inheritance-possible-p) + '((t (:inherit font-lock-warning-face))) + '((t (:foreground "OrangeRed")))) + "Face for labels of inspector actions." + :group 'slime-inspector) + +(defface slime-inspector-type-face + '((t (:inherit font-lock-type-face))) + "Face for type description in inspector." + :group 'slime-inspector) + +(defvar slime-inspector-mark-stack '()) +(defvar slime-saved-window-config) + +(defun slime-inspect (string) + "Eval an expression and inspect the result." + (interactive + (list (slime-read-from-minibuffer "Inspect value (evaluated): " + (slime-sexp-at-point)))) + (slime-eval-async `(swank:init-inspector ,string) 'slime-open-inspector)) + +(define-derived-mode slime-inspector-mode fundamental-mode "Slime-Inspector" + (set-syntax-table lisp-mode-syntax-table) + (slime-set-truncate-lines) + (setq buffer-read-only t)) + +(defun slime-inspector-buffer () + (or (get-buffer "*Slime Inspector*") + (with-current-buffer (get-buffer-create "*Slime Inspector*") + (setq slime-inspector-mark-stack '()) + (slime-mode t) + (slime-inspector-mode) + (make-local-variable 'slime-saved-window-config) + (setq slime-saved-window-config (current-window-configuration)) + (current-buffer)))) + +(defmacro slime-inspector-fontify (face string) + `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) ,string)) + +(defun slime-open-inspector (inspected-parts &optional point) + "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 + (macrolet ((fontify (face string) + `(slime-inspector-fontify ,face ,string))) + (insert (fontify topline title)) + (while (eq (char-before) ?\n) + (backward-delete-char 1)) + (insert "\n [" (fontify label "type:") " " (fontify type type) "]\n" + (fontify label "--------------------") "\n") + (save-excursion + (mapc #'slime-inspector-insert-ispec content)) + (pop-to-buffer (current-buffer)) + (when point + (check-type point cons) + (ignore-errors + (goto-line (car point)) + (move-to-column (cdr point))))))))) + +(defun slime-inspector-insert-ispec (ispec) + (if (stringp ispec) + (insert ispec) + (destructure-case ispec + ((:value string id) + (slime-propertize-region + (list 'slime-part-number id + 'mouse-face 'highlight + 'face 'slime-inspector-value-face) + (insert string))) + ((:action string id) + (slime-insert-propertized (list 'slime-action-number id + 'mouse-face 'highlight + 'face 'slime-inspector-action-face) + string))))) + +(defun slime-inspector-position () + "Return a pair (Y-POSITION X-POSITION) representing the +position of point in the current buffer." + ;; We make sure we return absolute coordinates even if the user has + ;; narrowed the buffer. + (save-restriction + (widen) + (cons (cond ((fboundp 'line-number) + (line-number)) ; XEmacs + ((fboundp 'line-number-at-pos) + (line-number-at-pos)) ; Recent GNU Emacs + (t (1+ (count-lines 1 (point-at-bol))))) + (current-column)))) + +(defun slime-inspector-operate-on-point () + "If point is on a value then recursivly call the inspector on + that value. If point is on an action then call that action." + (interactive) + (let ((part-number (get-text-property (point) 'slime-part-number)) + (action-number (get-text-property (point) 'slime-action-number)) + (opener (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (when parts + (slime-open-inspector parts point)))))) + (cond (part-number + (slime-eval-async `(swank:inspect-nth-part ,part-number) + opener) + (push (slime-inspector-position) slime-inspector-mark-stack)) + (action-number + (slime-eval-async `(swank::inspector-call-nth-action ,action-number) + opener))))) + +(defun slime-inspector-operate-on-click (event) + "Inspect the value at the clicked-at position or invoke an action." + (interactive "@e") + (let ((point (posn-point (event-end event)))) + (cond ((and point + (or (get-text-property point 'slime-part-number) + (get-text-property point 'slime-action-number))) + (goto-char point) + (slime-inspector-operate-on-point)) + (t + (error "No clickable part here"))))) + +(defun slime-inspector-copy-down (number) + "Evaluate the slot at point via the REPL (to set `*')." + (interactive (list (or (get-text-property (point) 'slime-part-number) + (error "No part at point")))) + (slime-repl-send-string (format "%s" `(swank:inspector-nth-part ,number))) + (slime-repl)) + +(defun slime-inspector-pop () + (interactive) + (slime-eval-async + `(swank:inspector-pop) + (lambda (result) + (cond (result + (slime-open-inspector result (pop slime-inspector-mark-stack))) + (t + (message "No previous object") + (ding)))))) + +(defun slime-inspector-next () + (interactive) + (let ((result (slime-eval `(swank:inspector-next)))) + (cond (result + (push (slime-inspector-position) slime-inspector-mark-stack) + (slime-open-inspector result)) + (t (message "No next object") + (ding))))) + +(defun slime-inspector-quit () + (interactive) + (slime-eval-async `(swank:quit-inspector)) + (set-window-configuration slime-saved-window-config) + (kill-buffer (current-buffer))) + +(defun slime-find-inspectable-object (direction limit) + "Finds the next or previous inspectable object within the +current buffer, depending on whether DIRECTION is 'NEXT or +'PREV. LIMIT is the maximum or minimum position in the current +buffer. + +Returns a list of two values: If an object could be found, the +starting position of the found object and T is returned; +otherwise LIMIT and NIL is returned. +" + (let ((finder (ecase direction + (next 'next-single-property-change) + (prev 'previous-single-property-change)))) + (let ((prop nil) (curpos (point))) + (while (and (not prop) (not (= curpos limit))) + (let ((newpos (funcall finder curpos 'slime-part-number nil limit))) + (setq prop (get-text-property newpos 'slime-part-number)) + (setq curpos newpos))) + (list curpos (and prop t))))) + +(defun slime-inspector-next-inspectable-object (arg) + "Move point to the next inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move backwards." + (interactive "p") + (let ((maxpos (point-max)) (minpos (point-min)) + (previously-wrapped-p nil)) + ;; Forward. + (while (> arg 0) + (destructuring-bind (pos foundp) + (slime-find-inspectable-object 'next maxpos) + (if foundp + (progn (goto-char pos) (setq arg (1- arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char minpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))) + ;; Backward. + (while (< arg 0) + (destructuring-bind (pos foundp) + (slime-find-inspectable-object 'prev minpos) + ;; SLIME-OPEN-INSPECTOR inserts the title of an inspector page + ;; as a presentation at the beginning of the buffer; skip + ;; that. (Notice how this problem can not arise in ``Forward.'') + (if (and foundp (/= pos minpos)) + (progn (goto-char pos) (setq arg (1+ arg)) + (setq previously-wrapped-p nil)) + (if (not previously-wrapped-p) ; cycle detection + (progn (goto-char maxpos) (setq previously-wrapped-p t)) + (error "No inspectable objects"))))))) + + +(defun slime-inspector-previous-inspectable-object (arg) + "Move point to the previous inspectable object. +With optional ARG, move across that many objects. +If ARG is negative, move forwards." + (interactive "p") + (slime-inspector-next-inspectable-object (- arg))) + +(defun slime-inspector-describe () + (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:inspector-reinspect) + (lexical-let ((point (slime-inspector-position))) + (lambda (parts) + (slime-open-inspector parts point))))) + +(slime-define-keys slime-inspector-mode-map + ([return] 'slime-inspector-operate-on-point) + ([(meta return)] 'slime-inspector-copy-down) + ("\C-m" 'slime-inspector-operate-on-point) + ([mouse-2] 'slime-inspector-operate-on-click) + ("l" 'slime-inspector-pop) + ("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) + ([(shift tab)] 'slime-inspector-previous-inspectable-object) ; Emacs translates S-TAB + ([backtab] 'slime-inspector-previous-inspectable-object) ; to BACKTAB on X. + ("\M-." 'slime-edit-definition)) + + +;;;; Buffer selector + +(defvar slime-selector-methods nil + "List of buffer-selection methods for the `slime-select' command. +Each element is a list (KEY DESCRIPTION FUNCTION). +DESCRIPTION is a one-line description of what the key selects.") + +(defun slime-selector () + "Select a new buffer by type, indicated by a single character. +The user is prompted for a single character indicating the method by +which to choose a new buffer. The `?' character describes the +available methods. + +See `def-slime-selector-method' for defining new methods." + (interactive) + (message "Select [%s]: " + (apply #'string (mapcar #'car slime-selector-methods))) + (let* ((ch (save-window-excursion + (select-window (minibuffer-window)) + (read-char))) + (method (find ch slime-selector-methods :key #'car))) + (cond ((null method) + (message "No method for character: ?\%c" ch) + (ding) + (sleep-for 1) + (discard-input) + (slime-selector)) + (t + (funcall (third method)))))) + +(defmacro def-slime-selector-method (key description &rest body) + "Define a new `slime-select' buffer selection method. + +KEY is the key the user will enter to choose this method. + +DESCRIPTION is a one-line sentence describing how the method +selects a buffer. + +BODY is a series of forms which are evaluated when the selector +is chosen. The returned buffer is selected with +switch-to-buffer." + `(setq slime-selector-methods + (sort* (cons (list ,key ,description + (lambda () + (let ((buffer (progn ,@body))) + (cond ((get-buffer buffer) + (switch-to-buffer buffer)) + (t + (message "No such buffer: %S" buffer) + (ding)))))) + (remove* ,key slime-selector-methods :key #'car)) + #'< :key #'car))) + +(def-slime-selector-method ?? "Selector help buffer." + (ignore-errors (kill-buffer "*Select Help*")) + (with-current-buffer (get-buffer-create "*Select Help*") + (insert "Select Methods:\n\n") + (loop for (key line function) in slime-selector-methods + do (insert (format "%c:\t%s\n" key line))) + (help-mode) + (display-buffer (current-buffer) t) + (shrink-window-if-larger-than-buffer + (get-buffer-window (current-buffer)))) + (slime-selector) + (current-buffer)) + +(def-slime-selector-method ?r + "SLIME Read-Eval-Print-Loop." + (cond ((slime-current-connection) + (slime-output-buffer)) + ((y-or-n-p "No connection: start Slime? ") + (slime)))) + +(def-slime-selector-method ?i + "*inferior-lisp* buffer." + (cond ((and (slime-connected-p) (slime-process)) + (process-buffer (slime-process))) + (t + "*inferior-lisp*"))) + +(def-slime-selector-method ?v + "*slime-events* buffer." + slime-event-buffer-name) + +(def-slime-selector-method ?l + "most recently visited lisp-mode buffer." + (slime-recently-visited-buffer 'lisp-mode)) + +(def-slime-selector-method ?d + "*sldb* buffer for the current connection." + (or (sldb-get-default-buffer) + (error "No debugger buffer"))) + +(def-slime-selector-method ?e + "most recently visited emacs-lisp-mode buffer." + (slime-recently-visited-buffer 'emacs-lisp-mode)) + +(def-slime-selector-method ?c + "SLIME connections buffer." + (slime-list-connections) + "*SLIME connections*") + +(def-slime-selector-method ?t + "SLIME threads buffer." + (slime-list-threads) + (slime-eval `(cl:quote nil)) ;wait until slime-list-threads returns + "*slime-threads*") + +(defun slime-recently-visited-buffer (mode) + "Return the most recently visited buffer whose major-mode is MODE. +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))) + + +;;;; Editing commands + + + +;;;; Font Lock + +(defcustom slime-highlight-suppressed-forms t + "Display forms disabled by reader conditionals as comments." + :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) + :group 'slime-mode) + +(defface slime-reader-conditional-face + (if (slime-face-inheritance-possible-p) + '((t (:inherit font-lock-comment-face))) + '((((background light)) (:foreground "DimGray" :bold t)) + (((background dark)) (:foreground "LightGray" :bold t)))) + "Face for compiler notes while selected." + :group 'slime-mode-faces) + +(defun slime-search-suppressed-forms (limit) + "Find reader conditionalized forms where the test is false." + (when (and slime-highlight-suppressed-forms + (slime-connected-p) + (re-search-forward "^\([^;\n]*?[ \t(]\)?#[-+]" limit t)) + (ignore-errors + (let* ((start (- (point) 2)) + (char (char-before)) + (e (read (current-buffer))) + (val (slime-eval-feature-conditional e))) + (when (<= (point) limit) + (if (or (and (eq char ?+) (not val)) + (and (eq char ?-) val)) + (progn + (forward-sexp) (backward-sexp) + (slime-forward-sexp) + (assert (<= (point) limit)) + (let ((md (match-data))) + (fill md nil) + (setf (first md) start) + (setf (second md) (point)) + (set-match-data md) + t)) + (slime-search-suppressed-forms limit))))))) + +(defun slime-activate-font-lock-magic () + (if (featurep 'xemacs) + (let ((pattern `((slime-search-suppressed-forms + (0 slime-reader-conditional-face t))))) + (dolist (sym '(lisp-font-lock-keywords + lisp-font-lock-keywords-1 + lisp-font-lock-keywords-2)) + (set sym (append (symbol-value sym) pattern)))) + (font-lock-add-keywords + 'lisp-mode + `((slime-search-suppressed-forms 0 ,''slime-reader-conditional-face t))))) + +(when slime-highlight-suppressed-forms + (slime-activate-font-lock-magic)) + + +;;;; Indentation + +(defun slime-update-indentation () + "Update indentation for all macros defined in the Lisp system." + (interactive) + (slime-eval-async '(swank:update-indentation-information))) + +(defvar slime-indentation-update-hooks) + +(defun slime-handle-indentation-update (alist) + "Update Lisp indent information. + +ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation +settings for `common-lisp-indent-function'. The appropriate property +is setup, unless the user already set one explicitly." + (dolist (info alist) + (let ((symbol (intern (car info))) + (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)) + (run-hook-with-args 'slime-indentation-update-hooks symbol indent)))) + + +;;;;; Pull-down menu + +(defvar slime-easy-menu + (let ((C '(slime-connected-p))) + `("SLIME" + [ "Edit Definition..." slime-edit-definition ,C ] + [ "Return From Definition" slime-pop-find-definition-stack ,C ] + [ "Complete Symbol" slime-complete-symbol ,C ] + [ "Show REPL" slime-switch-to-output-buffer ,C ] + "--" + ("Evaluation" + [ "Eval Defun" slime-eval-defun ,C ] + [ "Eval Last Expression" slime-eval-last-expression ,C ] + [ "Eval And Pretty-Print" slime-pprint-eval-last-expression ,C ] + [ "Eval Region" slime-eval-region ,C ] + [ "Interactive Eval..." slime-interactive-eval ,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 ] + [ "Create Trace Buffer" slime-redirect-trace-output ,C ] + [ "Toggle Trace..." slime-toggle-trace-fdefinition ,C ] + [ "Untrace All" slime-untrace-all ,C] + [ "Disassemble..." slime-disassemble-symbol ,C ] + [ "Inspect..." slime-inspect ,C ]) + ("Compilation" + [ "Compile Defun" slime-compile-defun ,C ] + [ "Compile/Load File" slime-compile-and-load-file ,C ] + [ "Compile File" slime-compile-file ,C ] + [ "Compile Region" slime-compile-region ,C ] + "--" + [ "Next Note" slime-next-note t ] + [ "Previous Note" slime-previous-note t ] + [ "Remove Notes" slime-remove-notes t ] + [ "List Notes" slime-list-compiler-notes ,C ]) + ("Cross Reference" + [ "Who Calls..." slime-who-calls ,C ] + [ "Who References... " slime-who-references ,C ] + [ "Who Sets..." slime-who-sets ,C ] + [ "Who Binds..." slime-who-binds ,C ] + [ "Who Macroexpands..." slime-who-macroexpands ,C ] + [ "Who Specializes..." slime-who-specializes ,C ] + [ "List Callers..." slime-list-callers ,C ] + [ "List Callees..." slime-list-callees ,C ] + [ "Next Location" slime-next-location t ]) + ("Editing" + [ "Check Parens" check-parens t] + [ "Update Indentation" slime-update-indentation ,C] + [ "Select Buffer" slime-selector t]) + ("Profiling" + [ "Toggle Profiling..." slime-toggle-profile-fdefinition ,C ] + [ "Profile Package" slime-profile-package ,C] + [ "Unprofile All" slime-unprofile-all ,C ] + [ "Show Profiled" slime-profiled-functions ,C ] + "--" + [ "Report" slime-profile-report ,C ] + [ "Reset Counters" slime-profile-reset ,C ]) + ("Documentation" + [ "Describe Symbol..." slime-describe-symbol ,C ] + [ "Apropos..." slime-apropos ,C ] + [ "Apropos all..." slime-apropos-all ,C ] + [ "Apropos Package..." slime-apropos-package ,C ] + [ "Hyperspec..." slime-hyperspec-lookup t ]) + "--" + [ "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]))) + +(defvar slime-repl-easy-menu + (let ((C '(slime-connected-p))) + `("REPL" + [ "Send Input" slime-repl-return ,C ] + [ "Close and Send Input " slime-repl-closing-return ,C ] + [ "Interrupt Lisp process" slime-interrupt ,C ] + "--" + [ "Previous Input" slime-repl-previous-input t ] + [ "Next Input" slime-repl-next-input t ] + [ "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 ] + [ "Kill Current Input" slime-repl-kill-input t ]))) + +(defvar slime-sldb-easy-menu + (let ((C '(slime-connected-p))) + `("SLDB" + [ "Next Frame" sldb-down t ] + [ "Previous Frame" sldb-up t ] + [ "Toggle Frame Details" sldb-toggle-details t ] + [ "Next Frame (Details)" sldb-details-down t ] + [ "Previous Frame (Details)" sldb-details-up t ] + "--" + [ "Eval Expression..." slime-interactive-eval ,C ] + [ "Eval in Frame..." sldb-eval-in-frame ,C ] + [ "Eval in Frame (pretty print)..." sldb-pprint-eval-in-frame ,C ] + [ "Inspect In Frame..." sldb-inspect-in-frame ,C ] + [ "Inspect Condition Object" sldb-inspect-condition ,C ] + [ "Print Condition to REPL" sldb-print-condition t ] + "--" + [ "Restart Frame" sldb-restart-frame ,C ] + [ "Return from Frame..." sldb-return-from-frame ,C ] + ("Invoke Restart" + [ "Continue" sldb-continue ,C ] + [ "Abort" sldb-abort ,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 ]))) + +(easy-menu-define menubar-slime slime-mode-map "SLIME" slime-easy-menu) + +(defun slime-add-easy-menu () + (easy-menu-add slime-easy-menu 'slime-mode-map)) + +(add-hook 'slime-mode-hook 'slime-add-easy-menu) + +(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 'slime-repl-mode-hook 'slime-repl-add-easy-menu) + +(defun slime-sldb-add-easy-menu () + (easy-menu-define menubar-slime-sldb + sldb-mode-map "SLDB" slime-sldb-easy-menu) + (easy-menu-add slime-sldb-easy-menu 'sldb-mode-map)) + +(add-hook 'sldb-mode-hook 'slime-sldb-add-easy-menu) + + +;;;; Cheat Sheet + +(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)))) + +(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))) + + +;;;; Test suite + +(defstruct (slime-test (:conc-name slime-test.)) + name fname args doc inputs fails-for) + +(defvar slime-tests '() + "Names of test functions.") + +(defvar slime-test-debug-on-error nil + "*When non-nil debug errors in test cases.") + +(defvar slime-total-tests nil + "Total number of tests executed during a test run.") + +(defvar slime-failed-tests nil + "Total number of failed tests during a test run.") + +(defvar slime-expected-failures nil + "Total number of expected failures during a test run") + +(defvar slime-test-buffer-name "*Tests*" + "The name of the buffer used to display test results.") + + +;; dynamically bound during a single test +(defvar slime-current-test) +(defvar slime-unexpected-failures) + + +;;;;; Execution engine + +(defun slime-run-tests () + "Run the test suite. +The results are presented in an outline-mode buffer, with the tests +that succeeded initially folded away." + (interactive) + (assert (not (slime-busy-p))) + (slime-create-test-results-buffer) + (unwind-protect + (slime-execute-tests) + (pop-to-buffer slime-test-buffer-name) + (goto-char (point-min)) + (hide-body) + ;; Expose failed tests + (dolist (o (overlays-in (point-min) (point-max))) + (when (overlay-get o 'slime-failed-test) + (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-name) + (slime-test.fails-for test))) + +(defun slime-execute-tests () + "Execute each test case with each input. +Return the number of failed tests." + (save-window-excursion + (let ((slime-total-tests 0) + (slime-expected-passes 0) + (slime-unexpected-failures 0) + (slime-expected-failures 0)) + (dolist (slime-current-test slime-tests) + (with-struct (slime-test. name (function fname) inputs) + slime-current-test + (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) + (debug-on-quit t)) + (apply function input)) + (condition-case err + (apply function input) + (error + (cond ((slime-test-should-fail-p slime-current-test) + (incf slime-expected-failures) + (slime-test-failure "ERROR (expected)" + (format "%S" err))) + (t + (incf slime-unexpected-failures) + (slime-print-check-error err))))))))) + (let ((summary (cond ((and (zerop slime-expected-failures) + (zerop slime-unexpected-failures)) + (format "All %S tests completed successfully." + slime-total-tests)) + (t + (format "Failed on %S (%S expected) of %S tests." + (+ slime-expected-failures + slime-unexpected-failures) + slime-expected-failures + slime-total-tests))))) + (save-excursion + (with-current-buffer slime-test-buffer-name + (goto-char (point-min)) + (insert summary "\n\n"))) + (message "%s" summary) + slime-unexpected-failures)))) + +(defun slime-batch-test (results-file) + "Run the test suite in batch-mode. +Exits Emacs when finished. The exit code is the number of failed tests." + (let ((slime-test-debug-on-error nil)) + (slime) + ;; Block until we are up and running. + (while (not (slime-connected-p)) + (sit-for 1)) + (slime-sync-to-top-level 5) + (switch-to-buffer "*scratch*") + (let ((failed-tests (slime-run-tests))) + (with-current-buffer slime-test-buffer-name + (slime-delete-hidden-outline-text) + (goto-char (point-min)) + (insert "-*- outline -*-\n\n") + (write-file results-file)) + (kill-emacs failed-tests)))) + + +;;;;; Results buffer creation and output + +(defun slime-create-test-results-buffer () + "Create and initialize the buffer for test suite results." + (ignore-errors (kill-buffer slime-test-buffer-name)) + (with-current-buffer (get-buffer-create slime-test-buffer-name) + (erase-buffer) + (outline-mode) + (set (make-local-variable 'outline-regexp) "\*+") + (slime-set-truncate-lines))) + +(defun slime-delete-hidden-outline-text () + "Delete the hidden parts of an outline-mode buffer." + (loop do (when (eq (get-char-property (point) 'invisible) 'outline) + (delete-region (point) + (next-single-char-property-change (point) + 'invisible))) + until (eobp) + do (goto-char (next-single-char-property-change (point) 'invisible)))) + +(defun slime-test-heading (level format &rest args) + "Output a test suite heading. +LEVEL gives the depth of nesting: 1 for top-level, 2 for a subheading, etc." + (with-current-buffer slime-test-buffer-name + (goto-char (point-max)) + (insert (make-string level ?*) + " " + (apply 'format format args) + "\n"))) + +(defun slime-test-failure (keyword string) + "Output a failure message from the test suite. +KEYWORD names the type of failure and STRING describes the reason." + (with-current-buffer slime-test-buffer-name + (goto-char (point-max)) + (let ((start (point))) + (insert keyword ": ") + (let ((overlay (make-overlay start (point)))) + (overlay-put overlay 'slime-failed-test t) + (overlay-put overlay 'face 'bold))) + (insert string "\n"))) + +(defun slime-test-message (string) + "Output a message from the test suite." + (with-current-buffer slime-test-buffer-name + (goto-char (point-max)) + (insert string "\n"))) + + +;;;;; Macros for defining test cases + +(defmacro def-slime-test (name args doc inputs &rest body) + "Define a test case. +NAME ::= SYMBOL | (SYMBOL (FAILS-FOR*)) is a symbol naming the test. +ARGS is a lambda-list. +DOC is a docstring. +INPUTS is a list of argument lists, each tested separately. +BODY is the test case. The body can use `slime-check' to test +conditions (assertions)." + (multiple-value-bind (name fails-for) (etypecase name + (symbol (values name '())) + (cons name)) + (let ((fname (intern (format "slime-test-%s" name)))) + `(progn + (defun ,fname ,args + ,doc + (slime-sync) + ,@body) + (setq slime-tests + (append (remove* ',name slime-tests :key 'slime-test.name) + (list (make-slime-test :name ',name :fname ',fname + :fails-for ',fails-for + :inputs ,inputs)))))))) + +(defmacro slime-check (test-name &rest body) + "Check a condition (assertion.) +TEST-NAME can be a symbol, a string, or a (FORMAT-STRING . ARGS) list. +BODY returns true if the check succeeds." + (let ((check-name (gensym "check-name-"))) + `(let ((,check-name ,(typecase test-name + (symbol (symbol-name test-name)) + (string test-name) + (cons `(format ,@test-name))))) + (if (progn ,@body) + (slime-print-check-ok ,check-name) + (cond ((slime-test-should-fail-p slime-current-test) + (incf slime-expected-failures) + (slime-test-failure "FAIL (expected)" ,check-name)) + (t + (incf slime-unexpected-failures) + (slime-print-check-failed ,check-name))) + (when slime-test-debug-on-error + (debug (format "Check failed: %S" ,check-name))))))) + +(defun slime-print-check-ok (test-name) + (slime-test-message test-name)) + +(defun slime-print-check-failed (test-name) + (slime-test-failure "FAILED" test-name)) + +(defun slime-print-check-error (reason) + (slime-test-failure "ERROR" (format "%S" reason))) + +(put 'def-slime-test 'lisp-indent-function 4) +(put 'slime-check 'lisp-indent-function 1) + + +;;;;; Test case definitions + +;; Clear out old tests. +(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))) + +(defun slime-at-top-level-p () + (and (not (sldb-get-default-buffer)) + (null (slime-rex-continuations)))) + +(defun slime-wait-condition (name predicate timeout) + (let ((end (time-add (current-time) (seconds-to-time timeout)))) + (while (not (funcall predicate)) + (cond ((time-less-p end (current-time)) + (error "Timeout waiting for condition: %S" name)) + (t + ;; 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)) + +;; XXX: unused function +(defun slime-check-sldb-level (expected) + (let ((sldb-level (when-let (sldb (sldb-get-default-buffer)) + (with-current-buffer sldb + sldb-level)))) + (slime-check ("SLDB level (%S) is %S" expected sldb-level) + (equal expected sldb-level)))) + +(defun slime-test-expect (name expected actual &optional test) + (when (stringp expected) (setq expected (substring-no-properties expected))) + (when (stringp actual) (setq actual (substring-no-properties actual))) + (slime-check ("%s:\nexpected: [%S]\n actual: [%S]" name expected actual) + (funcall (or test #'equal) expected actual))) + +(defun sldb-level () + (when-let (sldb (sldb-get-default-buffer)) + (with-current-buffer sldb + sldb-level))) + +(defun slime-sldb-level= (level) + (when-let (sldb (sldb-get-default-buffer)) + (with-current-buffer sldb + (equal sldb-level level)))) + +(def-slime-test narrowing + () + "Check that narrowing is properly sustained." + '(()) + (slime-check-top-level) + (let ((random-buffer-name (symbol-name (gensym))) + (defun-pos) (tmpbuffer)) + (with-temp-buffer + (dotimes (i 100) (insert (format ";;; %d. line\n" i))) + (setq tmpbuffer (current-buffer)) + (setq defun-pos (point)) + (insert (concat "(defun __foo__ (x y)" "\n" + " 'nothing)" "\n")) + (dotimes (i 100) (insert (format ";;; %d. line\n" (+ 100 i)))) + (slime-check "Checking that newly created buffer is not narrowed." + (not (slime-buffer-narrowed-p))) + + (goto-char defun-pos) + (narrow-to-defun) + (slime-check "Checking that narrowing succeeded." + (slime-buffer-narrowed-p)) + + (slime-with-output-to-temp-buffer (random-buffer-name) nil + (slime-check ("Checking that we're in Slime's temp buffer `%s'" random-buffer-name) + (equal (buffer-name (current-buffer)) random-buffer-name)) + (slime-temp-buffer-quit)) + (kill-buffer random-buffer-name) + (slime-check ("Checking that we've got back from `%s'" random-buffer-name) + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (slime-check "Checking that narrowing sustained after quitting Slime's temp buffer." + (slime-buffer-narrowed-p)) + + (let ((slime-buffer-package "SWANK") + (symbol '*buffer-package*)) + (slime-edit-definition (symbol-name symbol)) + (slime-check ("Checking that we've got M-. into swank.lisp." symbol) + (string= (file-name-nondirectory (buffer-file-name)) + "swank.lisp")) + (slime-pop-find-definition-stack) + (slime-check ("Checking that we've got back.") + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (slime-check "Checking that narrowing sustained after M-," + (slime-buffer-narrowed-p))) + )) + (slime-check-top-level)) + + +(def-slime-test find-definition + (name buffer-package snippet) + "Find the definition of a function or macro in swank.lisp." + '(("read-from-emacs" "SWANK" "(defun read-from-emacs ") + ("swank::read-from-emacs" "CL-USER" "(defun read-from-emacs ") + ("swank:start-server" "CL-USER" "(defun start-server ")) + (switch-to-buffer "*scratch*") ; not buffer of definition + (slime-check-top-level) + (let ((orig-buffer (current-buffer)) + (orig-pos (point)) + (enable-local-variables nil) ; don't get stuck on -*- eval: -*- + (slime-buffer-package buffer-package)) + (slime-edit-definition name) + ;; Postconditions + (slime-check ("Definition of `%S' is in swank.lisp." name) + (string= (file-name-nondirectory (buffer-file-name)) "swank.lisp")) + (slime-check "Definition now at point." (looking-at snippet)) + (slime-pop-find-definition-stack) + (slime-check "Returning from definition restores original buffer/position." + (and (eq orig-buffer (current-buffer)) + (= orig-pos (point))))) + (slime-check-top-level)) + +(def-slime-test complete-symbol + (prefix expected-completions) + "Find the completions of a symbol-name prefix." + '(("cl:compile" (("cl:compile" "cl:compile-file" "cl:compile-file-pathname" + "cl:compiled-function" "cl:compiled-function-p" "cl:compiler-macro" + "cl:compiler-macro-function") + "cl:compile")) + ("cl:foobar" (nil "")) + ("swank::compile-file" (("swank::compile-file" + "swank::compile-file-for-emacs" + "swank::compile-file-if-needed" + "swank::compile-file-pathname") + "swank::compile-file")) + ("cl:m-v-l" (nil ""))) + (let ((completions (slime-simple-completions prefix))) + (slime-test-expect "Completion set" expected-completions completions))) + +(def-slime-test arglist + ;; N.B. Allegro apparently doesn't return the default values of + ;; optional parameters. Thus the regexp in the start-server + ;; expected value. In a perfect world we'd find a way to smooth + ;; over this difference between implementations--perhaps by + ;; convincing Franz to provide a function that does what we want. + (function-name expected-arglist) + "Lookup the argument list for FUNCTION-NAME. +Confirm that EXPECTED-ARGLIST is displayed." + '(("swank::operator-arglist" "(swank::operator-arglist name package)") + ("swank::create-socket" "(swank::create-socket host port)") + ("swank::emacs-connected" "(swank::emacs-connected )") + ("swank::compile-string-for-emacs" + "(swank::compile-string-for-emacs string buffer position directory)") + ("swank::connection.socket-io" + "(swank::connection.socket-io \(struct\(ure\)?\|object\|instance\))") + ("cl:lisp-implementation-type" "(cl:lisp-implementation-type )") + ("cl:class-name" + "(cl:class-name \(class\|object\|instance\|structure\))")) + (slime-check-top-level) + (let ((arglist (slime-eval `(swank:operator-arglist ,function-name + "swank")))) + (slime-test-expect "Argument list is as expected" + expected-arglist (downcase arglist) + #'string-match)) + (slime-check-top-level)) + +(def-slime-test (compile-defun ("allegro" "lispworks" "clisp")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that SUBFORM is correctly located." + '(("(defun cl-user::foo () (cl-user::bar))" (cl-user::bar)) + ("(defun cl-user::foo () + #\space + ;;Sdf + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + #+(or)skipped + #| #||# + #||# |# + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + (list `(1 ,(random 10) 2 ,@(random 10) 3 ,(cl-user::bar))))" + (cl-user::bar)) + ("(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) + (with-temp-buffer + (lisp-mode) + (insert program) + (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 + (equal (read (current-buffer)) + subform))) + (slime-check-top-level)) + +(def-slime-test async-eval-debugging (depth) + "Test recursive debugging of asynchronous evaluation requests." + '((1) (2) (3)) + (slime-check-top-level) + (lexical-let ((depth depth) + (debug-hook-max-depth 0)) + (let ((debug-hook + (lambda () + (with-current-buffer (sldb-get-default-buffer) + (when (> sldb-level debug-hook-max-depth) + (setq debug-hook-max-depth sldb-level) + (if (= sldb-level depth) + ;; We're at maximum recursion - time to unwind + (sldb-quit) + ;; Going down - enter another recursive debug + ;; Recursively debug. + (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 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 (sldb-first-abort-restart))) + (t + (slime-eval-async `(cl:aref cl:nil ,sldb-level))))) + (leave + (cond ((= sldb-level level1) + (setq state 'ok) + (sldb-quit)) + (t + (sldb-invoke-restart (sldb-first-abort-restart)) + )))))))) + (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)))))) + +(defun sldb-first-abort-restart () + (let ((case-fold-search t)) + (position-if (lambda (x) (string-match "abort" (car x))) sldb-restarts))) + +(def-slime-test loop-interrupt-quit + () + "Test interrupting a loop." + '(()) + (slime-check-top-level) + (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (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) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5) + (slime-check-top-level)) + +(def-slime-test loop-interrupt-continue-interrupt-quit + () + "Test interrupting a previously interrupted but continued loop." + '(()) + (slime-check-top-level) + (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (sleep-for 1) + (slime-wait-condition "running" #'slime-busy-p 5) + (slime-interrupt) + (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-continue)) + (slime-wait-condition "running" (lambda () + (and (slime-busy-p) + (not (sldb-get-default-buffer)))) 5) + (slime-interrupt) + (slime-wait-condition "Second interrupt" (lambda () (slime-sldb-level= 1)) 5) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5) + (slime-check-top-level)) + +(def-slime-test interactive-eval + () + "Test interactive eval and continuing from the debugger." + '(()) + (slime-check-top-level) + (lexical-let ((done nil)) + (let ((sldb-hook (lambda () (sldb-continue) (setq done t)))) + (slime-interactive-eval + "(progn(cerror "foo" "restart")(cerror "bar" "restart")(+ 1 2))") + (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)))))) + +(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: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)))) + 30) + (with-current-buffer (sldb-get-default-buffer) + (sldb-quit)) + (slime-sync-to-top-level 5)) + +(def-slime-test package-updating + (package-name nicknames) + "Test if slime-lisp-package is updated." + '(("COMMON-LISP" ("CL")) + ("KEYWORD" ("" "KEYWORD")) + ("COMMON-LISP-USER" ("CL-USER"))) + (with-current-buffer (slime-output-buffer) + (let ((p (slime-eval + `(swank:listener-eval + ,(format + "(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 ("slime-lisp-package is %S." package-name) + (equal (slime-lisp-package) package-name)) + (slime-check ("slime-lisp-package-prompt-string is in %S." nicknames) + (member (slime-lisp-package-prompt-string) nicknames))))) + +(def-slime-test repl-test + (input result-contents) + "Test simple commands in the minibuffer." + '(("(+ 1 2)" "SWANK> (+ 1 2) +3 +SWANK> ") + ("(princ 10)" "SWANK> (princ 10) +10 +10 +SWANK> ") + ("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20) +1020 +20 +SWANK> ") + ("(dotimes (i 10 77) (princ i) (terpri))" + "SWANK> (dotimes (i 10 77) (princ i) (terpri)) +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +77 +SWANK> ")) + (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package-prompt-string) "SWANK")) + (kill-buffer (slime-output-buffer)) + (with-current-buffer (slime-output-buffer) + (insert input) + (slime-test-expect "Buffer contains input" + (concat "SWANK> " input) + (buffer-string)) + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)))) + +(def-slime-test repl-return + (before after result-contents) + "Test if slime-repl-return sends the correct protion to Lisp even +if point is not at the end of the line." + '(("(+ 1 2)" "" "SWANK> (+ 1 2) +3 +SWANK> ") +("(+ 1 " "2)" "SWANK> (+ 1 2) +3 +SWANK> ") + +("(+ 1\n" "2)" "SWANK> (+ 1 +2) +3 +SWANK> ")) + (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package-prompt-string) "SWANK")) + (kill-buffer (slime-output-buffer)) + (with-current-buffer (slime-output-buffer) + (insert before) + (save-excursion (insert after)) + (slime-test-expect "Buffer contains input" + (concat "SWANK> " before after) + (buffer-string)) + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)))) + +(def-slime-test repl-read + (prompt input result-contents) + "Test simple commands in the minibuffer." + '(("(read-line)" "foo" "SWANK> (values (read-line)) +foo +"foo" +SWANK> ") + ("(read-char)" "1" "SWANK> (values (read-char)) +1 +#\1 +SWANK> ") + ("(read)" "(+ 2 3 +4)" "SWANK> (values (read)) +(+ 2 3 +4) +(+ 2 3 4) +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)) + (with-current-buffer (slime-output-buffer) + (insert (format "(values %s)" prompt)) + (call-interactively 'slime-repl-return) + (slime-wait-condition "reading" #'slime-reading-p 5) + (insert input) + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)))) + +(def-slime-test repl-read-lines + (command inputs final-contents) + "Test reading multiple lines from the repl." + '(("(list (read-line) (read-line) (read-line))" + ("a" "b" "c") + "SWANK> (list (read-line) (read-line) (read-line)) +a +b +c +("a" "b" "c") +SWANK> ")) + (when (slime-output-buffer) + (kill-buffer (slime-output-buffer))) + (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package-prompt-string) "SWANK") + (insert command) + (call-interactively 'slime-repl-return) + (dolist (input inputs) + (slime-wait-condition "reading" #'slime-reading-p 5) + (insert input) + (call-interactively 'slime-repl-return)) + (slime-sync-to-top-level 5) + (slime-check "Buffer contains result" + (equal final-contents (buffer-string))))) + +(def-slime-test repl-type-ahead + (command input final-contents) + "Ensure that user input is preserved correctly. +In particular, input inserted while waiting for a result." + '(("(sleep 1)" "foo" "SWANK> (sleep 1) +NIL +SWANK> foo")) + (when (slime-output-buffer) + (kill-buffer (slime-output-buffer))) + (setf (slime-lisp-package-prompt-string) "SWANK") + (with-current-buffer (slime-output-buffer) + (insert command) + (call-interactively 'slime-repl-return) + (insert input) + (slime-sync-to-top-level 5) + (slime-check "Buffer contains result" + (equal final-contents (buffer-string))))) + +(def-slime-test interactive-eval-output + (input result-contents visiblep) + "Test simple commands in the minibuffer." + '(("(+ 1 2)" ";;;; (+ 1 2) ... +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)) + (with-current-buffer (slime-output-buffer) + (slime-interactive-eval input) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)) + (slime-test-expect "Buffer visible?" + visiblep + (not (not (get-buffer-window (current-buffer))))))) + +(def-slime-test break + () + "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)))) + 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 interrupt-at-toplevel + () + "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 interrupt-in-blocking-read + () + "Let's see what happens if we interrupt a blocking read operation." + '(()) + (slime-check-top-level) + (when (slime-output-buffer) + (setf (slime-lisp-package-prompt-string) "SWANK") + (kill-buffer (slime-output-buffer))) + (with-current-buffer (slime-output-buffer) + (insert "(read-char)") + (call-interactively 'slime-repl-return)) + (slime-wait-condition "reading" #'slime-reading-p 5) + (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-continue)) + (slime-wait-condition "reading" #'slime-reading-p 5) + (with-current-buffer (slime-output-buffer) + (insert "X") + (call-interactively 'slime-repl-return) + (slime-sync-to-top-level 5) + (slime-test-expect "Buffer contains result" + "SWANK> (read-char) +X +#\X +SWANK> " (buffer-string)))) + +(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) nil "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 + +;;;;; Misc. + +(defun slime-length= (seq n) + "Test for whether SEQ contains N number of elements. I.e. it's equivalent + to (= (LENGTH SEQ) N), but besides being more concise, it may also be more + efficiently implemented." + (etypecase seq + (list + (let ((list seq)) + (setq list (nthcdr (1- n) list)) + (and list (null (cdr list))))) + (sequence + (= (length seq) n)))) + +(defun slime-length> (seq n) + "Return non-nil if (> (length LIST) N)." + (etypecase seq + (list (nthcdr n seq)) + (seq (> (length seq) n)))) + +(defun slime-split-string (string &optional separators omit-nulls) + "This is like `split-string' in Emacs22, but also works in +Emacs20 and 21." + (let ((splits (split-string string separators))) + (if omit-nulls + (setq splits (remove "" splits)) + ;; SPLIT-STRING in Emacs before 22.x automatically removed nulls + ;; at beginning and end, so we gotta add them here again. + (when (or (slime-emacs-20-p) (slime-emacs-21-p)) + (when (find (elt string 0) separators) + (push "" splits)) + (when (find (elt string (1- (length string))) separators) + (setq splits (append splits (list "")))))) + splits)) + +;;;;; Buffer related + +(defun slime-buffer-narrowed-p (&optional buffer) + "Returns T if BUFFER (or the current buffer respectively) is narrowed." + (with-current-buffer (or buffer (current-buffer)) + (let ((beg (point-min)) + (end (point-max)) + (total (buffer-size))) + (or (/= beg 1) (/= end (1+ total)))))) + + +;;;;; Extracting Lisp forms from the buffer or user + +(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 + (save-match-data + (end-of-defun) + (let ((end (point))) + (beginning-of-sexp) + (list (point) end))))) + +(defun slime-beginning-of-symbol () + "Move point to the beginning of the current symbol." + (when (slime-point-moves-p + (while (slime-point-moves-p + (skip-syntax-backward "w_") + (when (eq (char-before) ?|) + (backward-char))))) + (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." + (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-char))))) + +(put 'slime-symbol 'end-op 'slime-end-of-symbol) +(put 'slime-symbol 'beginning-op 'slime-beginning-of-symbol) + +(defun slime-symbol-start-pos () + "Return the starting position of the symbol under point. +The result is unspecified if there isn't a symbol under the point." + (save-excursion (slime-beginning-of-symbol) (point))) + +(defun slime-symbol-end-pos () + (save-excursion (slime-end-of-symbol) (point))) + +(defun slime-symbol-name-at-point () + "Return the name of the symbol at point, otherwise nil." + (save-restriction + ;; Don't be tricked into grabbing the REPL prompt. + (when (and (eq major-mode 'slime-repl-mode) + (>= (point) slime-repl-input-start-mark)) + (narrow-to-region slime-repl-input-start-mark (point-max))) + (save-excursion + (let ((string (thing-at-point 'slime-symbol))) + (and string + ;; In Emacs20 (thing-at-point 'symbol) returns "" instead + ;; of nil when called from an empty (or + ;; narrowed-to-empty) buffer. + (not (equal string "")) + (substring-no-properties string)))))) + +(defun slime-symbol-at-point () + "Return the symbol at point, otherwise nil." + (let ((name (slime-symbol-name-at-point))) + (and name (intern name)))) + +(defun slime-sexp-at-point () + "Return the sexp at point as a string, otherwise nil." + (let ((string (thing-at-point 'sexp))) + (if string (substring-no-properties string) nil))) + +(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."))) + +;;;; Portability library + +(when (featurep 'xemacs) + (require 'overlay)) + +(defmacro slime-defun-if-undefined (name &rest rest) + ;; We can't decide at compile time whether NAME is properly + ;; bound. So we delay the decision to runtime to ensure some + ;; definition + `(unless (fboundp ',name) + (defun ,name ,@rest))) + +(put 'slime-defun-if-undefined 'lisp-indent-function 2) + +(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))))))) + +(slime-defun-if-undefined next-single-char-property-change + (position prop &optional object limit) + (let ((limit (typecase limit + (null nil) + (marker (marker-position limit)) + (t limit)))) + (if (stringp object) + (or (next-single-property-change position prop object limit) + limit + (length object)) + (with-current-buffer (or object (current-buffer)) + (let ((initial-value (get-char-property position prop object)) + (limit (or limit (point-max)))) + (loop for pos = position then (next-char-property-change pos limit) + if (>= pos limit) return limit + if (not (eq initial-value + (get-char-property pos prop object))) + return pos)))))) + +(slime-defun-if-undefined previous-single-char-property-change + (position prop &optional object limit) + (let ((limit (typecase limit + (null nil) + (marker (marker-position limit)) + (t limit)))) + (if (stringp object) + (or (previous-single-property-change position prop object limit) + limit + (length object)) + (with-current-buffer (or object (current-buffer)) + (let ((limit (or limit (point-min)))) + (if (<= position limit) + limit + (let ((initial-value (get-char-property (1- position) + prop object))) + (loop for pos = position then + (previous-char-property-change pos limit) + if (<= pos limit) return limit + if (not (eq initial-value + (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 0 (- end start) nil string) + string)) + +(slime-defun-if-undefined match-string-no-properties (num &optional string) + (if (match-beginning num) + (if string + (substring-no-properties string (match-beginning num) + (match-end num)) + (buffer-substring-no-properties (match-beginning num) + (match-end num))))) + +(slime-defun-if-undefined set-window-text-height (window height) + (let ((delta (- height (window-text-height window)))) + (unless (zerop delta) + (let ((window-min-height 1)) + (if (and window (not (eq window (selected-window)))) + (save-selected-window + (select-window window) + (enlarge-window delta)) + (enlarge-window delta)))))) + +(slime-defun-if-undefined window-text-height (&optional window) + (1- (window-height window))) + +(slime-defun-if-undefined subst-char-in-string (fromchar tochar string + &optional inplace) + "Replace FROMCHAR with TOCHAR in STRING each time it occurs. +Unless optional argument INPLACE is non-nil, return a new string." + (let ((i (length string)) + (newstr (if inplace string (copy-sequence string)))) + (while (> i 0) + (setq i (1- i)) + (if (eq (aref newstr i) fromchar) + (aset newstr i tochar))) + newstr)) + +(slime-defun-if-undefined count-screen-lines + (&optional beg end count-final-newline window) + (unless beg + (setq beg (point-min))) + (unless end + (setq end (point-max))) + (if (= beg end) + 0 + (save-excursion + (save-restriction + (widen) + (narrow-to-region (min beg end) + (if (and (not count-final-newline) + (= ?\n (char-before (max beg end)))) + (1- (max beg end)) + (max beg end))) + (goto-char (point-min)) + ;; XXX make this xemacs compatible + (1+ (vertical-motion (buffer-size) window)))))) + +(slime-defun-if-undefined seconds-to-time (seconds) + "Convert SECONDS (a floating point number) to a time value." + (list (floor seconds 65536) + (floor (mod seconds 65536)) + (floor (* (- seconds (ffloor seconds)) 1000000)))) + +(slime-defun-if-undefined time-less-p (t1 t2) + "Say whether time value T1 is less than time value T2." + (or (< (car t1) (car t2)) + (and (= (car t1) (car t2)) + (< (nth 1 t1) (nth 1 t2))))) + +(slime-defun-if-undefined time-add (t1 t2) + "Add two time values. One should represent a time difference." + (let ((high (car t1)) + (low (if (consp (cdr t1)) (nth 1 t1) (cdr t1))) + (micro (if (numberp (car-safe (cdr-safe (cdr t1)))) + (nth 2 t1) + 0)) + (high2 (car t2)) + (low2 (if (consp (cdr t2)) (nth 1 t2) (cdr t2))) + (micro2 (if (numberp (car-safe (cdr-safe (cdr t2)))) + (nth 2 t2) + 0))) + ;; Add + (setq micro (+ micro micro2)) + (setq low (+ low low2)) + (setq high (+ high high2)) + + ;; Normalize + ;; `/' rounds towards zero while `mod' returns a positive number, + ;; so we can't rely on (= a (+ (* 100 (/ a 100)) (mod a 100))). + (setq low (+ low (/ micro 1000000) (if (< micro 0) -1 0))) + (setq micro (mod micro 1000000)) + (setq high (+ high (/ low 65536) (if (< low 0) -1 0))) + (setq low (logand low 65535)) + + (list high low micro))) + +(slime-defun-if-undefined line-beginning-position (&optional n) + (save-excursion + (beginning-of-line n) + (point))) + +(slime-defun-if-undefined line-end-position (&optional n) + (save-excursion + (end-of-line n) + (point))) + +(slime-defun-if-undefined check-parens () + "Verify that parentheses in the current buffer are balanced. +If they are not, position point at the first syntax error found." + (interactive) + (let ((saved-point (point)) + (state (parse-partial-sexp (point-min) (point-max) -1))) + (destructuring-bind (depth innermost-start last-terminated-start + in-string in-comment after-quote + minimum-depth comment-style + comment-or-string-start &rest _) state + (cond ((and (zerop depth) + (not in-string) + (or (not in-comment) + (and (eq comment-style nil) + (eobp))) + (not after-quote)) + (goto-char saved-point) + (message "All parentheses appear to be balanced.")) + ((plusp depth) + (goto-char innermost-start) + (error "Missing )")) + ((minusp depth) + (error "Extra )")) + (in-string + (goto-char comment-or-string-start) + (error "String not terminated")) + (in-comment + (goto-char comment-or-string-start) + (error "Comment not terminated")) + (after-quote + (error "After quote")) + (t (error "Shouldn't happen: parsing state: %S" state)))))) + +(slime-defun-if-undefined read-directory-name (prompt + &optional dir default-dirname + mustmatch initial) + (unless dir + (setq dir default-directory)) + (unless default-dirname + (setq default-dirname + (if initial (concat dir initial) default-directory))) + (let ((file (read-file-name prompt dir default-dirname mustmatch initial))) + (setq file (file-name-as-directory (expand-file-name file))) + (cond ((file-directory-p file) + file) + (t + (error "Not a directory: %s" file))))) + +(slime-defun-if-undefined check-coding-system (coding-system) + (or (eq coding-system 'binary) + (error "No such coding system: %S" coding-system))) + +(slime-defun-if-undefined process-coding-system (process) + '(binary . binary)) + +(slime-defun-if-undefined set-process-coding-system + (process &optional decoding encoding)) + +(unless (boundp 'temporary-file-directory) + (defvar temporary-file-directory + (file-name-as-directory + (cond ((memq system-type '(ms-dos windows-nt)) + (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp")) + ((memq system-type '(vax-vms axp-vms)) + (or (getenv "TMPDIR") (getenv "TMP") + (getenv "TEMP") "SYS$SCRATCH:")) + (t + (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))) + +(defun slime-emacs-21-p () + (and (not (featurep 'xemacs)) + (= emacs-major-version 21))) + +(when (featurep 'xemacs) + (add-hook 'sldb-hook 'sldb-xemacs-emulate-point-entered-hook)) + +(defun sldb-xemacs-emulate-point-entered-hook () + (add-hook (make-local-variable 'post-command-hook) + 'sldb-xemacs-post-command-hook)) + +(defun sldb-xemacs-post-command-hook () + (when (get-text-property (point) 'point-entered) + (funcall (get-text-property (point) 'point-entered)))) + +(slime-defun-if-undefined with-selected-window (window &rest body) + `(save-selected-window + (select-window ,window) + ,@body)) + +;;; Stuff only available in XEmacs +(slime-defun-if-undefined add-local-hook (hook function &optional append) + (make-local-hook hook) + (add-hook hook function append t)) + +(slime-defun-if-undefined remove-local-hook (hook function) + (if (local-variable-p hook (current-buffer)) + (remove-hook hook function t))) + +;;;; Some "nice" backward compatiblity bindings for lusers. + +(defvar slime-obsolete-commands + '(("\C-c\M-i" (slime repl) slime-fuzzy-complete-symbol) + ;; Don't shadow bindings in lisp-mode-map + ;;("\M-\C-a" (slime) slime-beginning-of-defun) + ;;("\M-\C-e" (slime) slime-end-of-defun) + ("\C-c\M-q" (slime) slime-reindent-defun) + ("\C-c\C-s" (slime) slime-complete-form) + ;; (nil nil slime-close-all-parens-in-sexp) + )) + +(defun slime-bind-obsolete-commands () + (loop for (key maps command) in slime-obsolete-commands do + (dolist (m maps) (slime-bind-obsolete-command m key command)))) + +(defun slime-bind-obsolete-command (map key command) + (let ((map (ecase map + (slime slime-mode-map) + (repl slime-repl-mode-map)))) + (unless (lookup-key map key) + (define-key map key `(lambda (&rest _) + (interactive) + (slime-upgrade-notice ',command)))))) + +(slime-bind-obsolete-commands) + +(defun slime-upgrade-notice (command) + (slime-timebomb (format "The command `%s' has been moved to contrib. +Please consult the README file in the contrib directory for details. + +To fetch the contrib directoy use: cvs update -d" + command) + 15)) + +;;;;; ... with gratuitous bloat + +(defun slime-timebomb (message timeout) + (with-current-buffer (generate-new-buffer "*warning*") + (insert message "\n\n") + (slime-timebomb-progress (point-marker) timeout) + (goto-char (point-min)) + (pop-to-buffer (current-buffer)))) + +(defun slime-timebomb-progress (mark timeout) + (let ((buffer (marker-buffer mark))) + (cond ((not (buffer-live-p buffer))) + ((zerop timeout) (kill-buffer buffer)) + (t (with-current-buffer buffer + (save-excursion + (delete-region mark (point-max)) + (goto-char mark) + (slime-timebomb-message timeout)) + (run-with-timer 1 nil + 'slime-timebomb-progress mark (1- timeout))))))) + +(defun slime-timebomb-message (timeout) + (slime-insert-propertized + (list 'face (if (zerop (mod timeout 2)) 'highlight 'default)) + (format "This message will destroy itself in %d seconds." timeout))) + + +;;;; Finishing up + +(require 'bytecomp) +(let ((byte-compile-warnings '())) + (mapc #'byte-compile + '(slime-alistify + slime-log-event + slime-events-buffer + slime-write-string + slime-output-buffer + slime-connection-output-buffer + slime-output-filter + slime-repl-show-maximum-output + slime-process-available-input + slime-dispatch-event + slime-net-filter + slime-net-have-input-p + slime-net-decode-length + slime-net-read + slime-print-apropos + slime-show-note-counts + slime-insert-propertized + slime-tree-insert))) + +(provide 'slime) +(run-hooks 'slime-load-hook) + +;; Local Variables: +;; outline-regexp: ";;;;+" +;; indent-tabs-mode: nil +;; coding: latin-1-unix! +;; unibyte: t +;; compile-command: "emacs -batch -L . -eval '(byte-compile-file "slime.el")' ; rm -v slime.elc" +;; End: +;;; slime.el ends here
Added: branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,541 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*- +;;; +;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME. +;;; +;;; Adapted from swank-acl.lisp, Andras Simon, 2004 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package :swank-backend) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :collect) ;just so that it doesn't spoil the flying letters + (require :pprint)) + +(defun sys::break (&optional (format-control "BREAK called") + &rest format-arguments) + (let ((*saved-backtrace* (backtrace-as-list-ignoring-swank-calls))) + (with-simple-restart (continue "Return from BREAK.") + (invoke-debugger + (sys::%make-condition 'simple-condition + (list :format-control format-control + :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 and definition + +(defclass standard-slot-definition ()()) + +;(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) (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 + standard-slot-definition ;;dummy + cl:method + cl:standard-class + ;; standard-class readers + mop::class-default-initargs + mop::class-direct-default-initargs + mop::class-direct-slots + mop::class-direct-subclasses + mop::class-direct-superclasses + mop::eql-specializer + mop::class-finalized-p + cl:class-name + mop::class-precedence-list + class-prototype ;;dummy + class-slots + specializer-direct-methods + ;; eql-specializer accessors + mop::eql-specializer-object + ;; generic function readers + mop::generic-function-argument-precedence-order + generic-function-declarations ;;dummy + mop::generic-function-lambda-list + mop::generic-function-methods + mop::generic-function-method-class + mop::generic-function-method-combination + mop::generic-function-name + ;; method readers + method-generic-function + method-function + mop::method-lambda-list + mop::method-specializers + mop::method-qualifiers + ;; slot readers + mop::slot-definition-allocation + slot-definition-documentation ;;dummy + mop::slot-definition-initargs + mop::slot-definition-initform + mop::slot-definition-initfunction + slot-definition-name + slot-definition-type ;;dummy + mop::slot-definition-readers + mop::slot-definition-writers + slot-boundp-using-class + slot-value-using-class + )) + +;;;; TCP Server + + +(defimplementation preferred-communication-style () + :spawn) + + + +(defimplementation create-socket (host port) + (ext:make-server-socket port)) + + +(defimplementation local-port (socket) + (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket)) + + +(defimplementation close-socket (socket) + (ext:server-socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout external-format)) + (ext:get-socket-stream (ext:socket-accept socket))) + +;;;; Unix signals + +(defimplementation call-without-interrupts (fn) + (funcall fn)) + +;;there are too many to count +(defimplementation getpid () + 0) + +(defimplementation lisp-implementation-type-name () + "armedbear") + +(defimplementation set-default-directory (directory) + (let ((dir (sys::probe-directory directory))) + (when dir (setf *default-pathname-defaults* dir)) + (namestring dir))) + + +;;;; Misc + +(defimplementation arglist (fun) + (cond ((symbolp fun) + (multiple-value-bind (arglist present) (sys::arglist fun) + (if present arglist :not-available))) + (t :not-available))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form) + (macroexpand form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + + +;;;; Debugger + +(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 (backtrace-as-list-ignoring-swank-calls)) #+nil (excl::int-newest-frame))) + (funcall debugger-loop-fn))) + +(defun nth-frame (index) + (nth index (backtrace-as-list-ignoring-swank-calls))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (subseq (backtrace-as-list-ignoring-swank-calls) start end))) + +(defimplementation print-frame (frame stream) + (write-string (string-trim '(#\space #\newline) + (prin1-to-string frame)) + stream)) + +(defimplementation frame-locals (index) + `(,(list :name "??" :id 0 :value "??"))) + + +(defimplementation frame-catch-tags (index) + (declare (ignore index)) + nil) + +#+nil +(defimplementation disassemble-frame (index) + (disassemble (debugger:frame-function (nth-frame index)))) + +(defimplementation frame-source-location-for-emacs (index) + (list :error (format nil "Cannot find source for frame: ~A" + (nth-frame index)))) + +#+nil +(defimplementation eval-in-frame (form frame-number) + (debugger:eval-form-in-context + form + (debugger:environment-of-frame (nth-frame frame-number)))) + +#+nil +(defimplementation return-from-frame (frame-number form) + (let ((frame (nth-frame frame-number))) + (multiple-value-call #'debugger:frame-return + frame (debugger:eval-form-in-context + form + (debugger:environment-of-frame frame))))) + +;;; XXX doesn't work for frames with arguments +#+nil +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (debugger:frame-retry frame (debugger:frame-function frame)))) + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(in-package :swank-backend) + +(defun handle-compiler-warning (condition) + (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 *compile-filename*) + (list :position 1))))))))) + +(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)) + (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 + +(defun find-fspec-location (fspec type) + (let ((file (excl::fspec-pathname fspec type))) + (etypecase file + (pathname + (let ((start (scm:find-definition-in-file fspec type file))) + (make-location (list :file (namestring (truename file))) + (if start + (list :position (1+ start)) + (list :function-name (string fspec)))))) + ((member :top-level) + (list :error (format nil "Defined at toplevel: ~A" fspec))) + (null + (list :error (format nil "Unkown source location for ~A" fspec)))))) + +(defun fspec-definition-locations (fspec) + (let ((defs (excl::find-multiple-definitions fspec))) + (loop for (fspec type) in defs + collect (list fspec (find-fspec-location fspec type))))) + +(defimplementation find-definitions (symbol) + (fspec-definition-locations symbol)) + +|# + +(defun source-location (symbol) + (when (pathnamep (ext:source-pathname symbol)) + `(((,symbol) + (:location + (:file ,(namestring (ext:source-pathname symbol))) + (:position ,(or (ext:source-file-position symbol) 0) t) + (:snippet nil)))))) + + +(defimplementation find-definitions (symbol) + (source-location symbol)) + +#| +Uncomment this if you have patched xref.lisp, as in +http://article.gmane.org/gmane.lisp.slime.devel/2425 +Also, make sure that xref.lisp is loaded by modifying the armedbear +part of *sysdep-pathnames* in swank.loader.lisp. + +;;;; XREF +(setq pxref:*handle-package-forms* '(cl:in-package)) + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls pxref:list-callers) +(defxref who-references pxref:list-readers) +(defxref who-binds pxref:list-setters) +(defxref who-sets pxref:list-setters) +(defxref list-callers pxref:list-callers) +(defxref list-callees pxref:list-callees) + +(defun xref-results (symbols) + (let ((xrefs '())) + (dolist (symbol symbols) + (push (list symbol (cadar (source-location symbol))) xrefs)) + xrefs)) +|# + +;;;; Inspecting + +(defclass abcl-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'abcl-inspector)) + +(defmethod inspect-for-emacs ((slot mop::slot-definition) + (inspector backend-inspector)) + (declare (ignore inspector)) + (values "A 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)) + "#<unspecified>") (:newline) + " Function: " (:value ,(mop::%slot-definition-initfunction slot)) + (:newline)))) + +(defmethod inspect-for-emacs ((f function) (inspector backend-inspector)) + (declare (ignore inspector)) + (values "A function." + `(,@(when (function-name f) + `("Name: " + ,(princ-to-string (function-name f)) (:newline))) + ,@(multiple-value-bind (args present) + (sys::arglist f) + (when present `("Argument list: " ,(princ-to-string args) (:newline)))) + (:newline) + #+nil,@(when (documentation f t) + `("Documentation:" (:newline) ,(documentation f t) (:newline))) + ,@(when (function-lambda-expression f) + `("Lambda expression:" + (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline)))))) + +#| + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (let* ((class (class-of o)) + (slots (mop::class-slots class))) + (values (format nil "~A~% is a ~A" o class) + (mapcar (lambda (slot) + (let ((name (mop::slot-definition-name slot))) + (cons (princ-to-string name) + (slot-value o name)))) + slots)))) +|# + +;;;; Multithreading + +(defimplementation startup-multiprocessing () + #+nil(mp:start-scheduler)) + +(defimplementation spawn (fn &key name) + (ext:make-thread (lambda () (funcall fn)) :name name)) + +(defvar *thread-props-lock* (ext:make-thread-lock)) + +(defvar *thread-props* (make-hash-table) ; should be a weak table + "A hashtable mapping threads to a plist.") + +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (ext:with-thread-lock (*thread-props-lock*) + (or (getf (gethash thread *thread-props*) 'id) + (setf (getf (gethash thread *thread-props*) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-props*) 'id)))) + +(defimplementation thread-name (thread) + (ext:thread-name thread)) + +(defimplementation thread-status (thread) + (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread))) + +(defimplementation make-lock (&key name) + (ext:make-thread-lock)) + +(defimplementation call-with-lock-held (lock function) + (ext:with-thread-lock (lock) (funcall function))) + +(defimplementation current-thread () + (ext:current-thread)) + +(defimplementation all-threads () + (copy-list (ext:mapcar-threads #'identity))) + +(defimplementation interrupt-thread (thread fn) + (ext:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (ext:destroy-thread thread)) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (ext:with-thread-lock (*thread-props-lock*) + (or (getf (gethash thread *thread-props*) 'mailbox) + (setf (getf (gethash thread *thread-props*) 'mailbox) + (ext:make-mailbox))))) + +(defimplementation send (thread object) + (ext:mailbox-send (mailbox thread) object)) + +(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)) + +;; WORKAROUND: call/initialize accessors at load time +(let ((c (make-condition 'compiler-condition + :original-condition nil + :severity ':note :message "" :location nil)) + (slots `(severity message short-message references location))) + (dolist (slot slots) + (funcall slot c)))
Added: branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,774 @@ +;;;; -*- 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. +;;; + +(in-package :swank-backend) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sock) + (require :process)) + +(import-from :excl *gray-stream-symbols* :swank-backend) + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port) + (socket:make-socket :connect :passive :local-port port + :local-host host :reuse-address t)) + +(defimplementation local-port (socket) + (socket:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format buffering + timeout) + (declare (ignore buffering timeout)) + (let ((s (socket:accept-connection socket :wait t))) + (when external-format + (setf (stream-external-format s) external-format)) + s)) + +(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)) + +(defimplementation call-with-syntax-hooks (fn) + (funcall fn)) + +;;;; Unix signals + +(defimplementation call-without-interrupts (fn) + (excl:without-interrupts (funcall fn))) + +(defimplementation getpid () + (excl::getpid)) + +(defimplementation lisp-implementation-type-name () + "allegro") + +(defimplementation set-default-directory (directory) + (let* ((dir (namestring (truename (merge-pathnames directory))))) + (setf *default-pathname-defaults* (pathname (excl:chdir dir))) + dir)) + +(defimplementation default-directory () + (namestring (excl:current-directory))) + +;;;; Misc + +(defimplementation arglist (symbol) + (handler-case (excl:arglist symbol) + (simple-error () :not-available))) + +(defimplementation macroexpand-all (form) + (excl::walk form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation make-stream-interactive (stream) + (setf (interactive-stream-p stream) t)) + +;;;; Debugger + +(defvar *sldb-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let ((*sldb-topframe* (find-topframe)) + (excl::*break-hook* nil)) + (funcall debugger-loop-fn))) + +(defimplementation sldb-break-at-start (fname) + ;; :print-before is kind of mis-used but we just want to stuff our break form + ;; somewhere. This does not work for setf, :before and :after methods, which + ;; need special syntax in the trace call, see ACL's doc/debugging.htm chapter 10. + (eval `(trace (,fname + :print-before + ((break "Function start breakpoint of ~A" ',fname))))) + `(:ok ,(format nil "Set breakpoint at start of ~S" fname))) + +(defun find-topframe () + (let ((skip-frames 3)) + (do ((f (excl::int-newest-frame) (next-frame f)) + (i 0 (1+ i))) + ((= i skip-frames) f)))) + +(defun next-frame (frame) + (let ((next (excl::int-next-older-frame frame))) + (cond ((not next) nil) + ((debugger:frame-visible-p next) next) + (t (next-frame next))))) + +(defun nth-frame (index) + (do ((frame *sldb-topframe* (next-frame frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (next-frame f) + for i from start below end + while f + collect f))) + +(defimplementation print-frame (frame stream) + (debugger:output-frame stream frame :moderate)) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for i from 0 below (debugger:frame-number-vars frame) + collect (list :name (debugger:frame-var-name frame i) + :id 0 + :value (debugger:frame-var-value frame i))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (debugger:frame-var-value frame var))) + +(defimplementation frame-catch-tags (index) + (declare (ignore index)) + nil) + +(defimplementation disassemble-frame (index) + (disassemble (debugger:frame-function (nth-frame index)))) + +(defimplementation frame-source-location-for-emacs (index) + (let* ((frame (nth-frame index)) + (expr (debugger:frame-expression frame)) + (fspec (first expr))) + (second (first (fspec-definition-locations fspec))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + ;; let-bind lexical variables + (let ((vars (loop for i below (debugger:frame-number-vars frame) + for name = (debugger:frame-var-name frame i) + if (symbolp name) + collect `(,name ',(debugger:frame-var-value frame i))))) + (debugger:eval-form-in-context + `(let* ,vars ,form) + (debugger:environment-of-frame frame))))) + +(defimplementation return-from-frame (frame-number form) + (let ((frame (nth-frame frame-number))) + (multiple-value-call #'debugger:frame-return + frame (debugger:eval-form-in-context + form + (debugger:environment-of-frame frame))))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (cond ((debugger:frame-retryable-p frame) + (apply #'debugger:frame-retry frame (debugger:frame-function frame) + (cdr (debugger:frame-expression frame)))) + (t "Frame is not retryable")))) + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +(defun compiler-note-p (object) + (member (type-of object) '(excl::compiler-note compiler::compiler-note))) + +(defun compiler-undefined-functions-called-warning-p (object) + (typep object 'excl:compiler-undefined-functions-called-warning)) + +(deftype compiler-note () + `(satisfies compiler-note-p)) + +(defun signal-compiler-condition (&rest args) + (signal (apply #'make-condition 'compiler-condition args))) + +(defun handle-compiler-warning (condition) + (declare (optimize (debug 3) (speed 0) (space 0))) + (cond ((and (not *buffer-name*) + (compiler-undefined-functions-called-warning-p condition)) + (handle-undefined-functions-warning condition)) + (t + (signal-compiler-condition + :original-condition condition + :severity (etypecase condition + (warning :warning) + (compiler-note :note)) + :message (format nil "~A" condition) + :location (location-for-warning condition))))) + +(defun location-for-warning (condition) + (let ((loc (getf (slot-value condition 'excl::plist) :loc))) + (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 + (list :error "No error location available."))))) + +(defun handle-undefined-functions-warning (condition) + (let ((fargs (slot-value condition 'excl::format-arguments))) + (loop for (fname . pos-file) in (car fargs) do + (loop for (pos file) in pos-file do + (signal-compiler-condition + :original-condition condition + :severity :warning + :message (format nil "Undefined function referenced: ~S" + fname) + :location (make-location (list :file file) + (list :position (1+ pos)))))))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-compiler-warning) + ;;(compiler-note #'handle-compiler-warning) + ) + (funcall function))) + +(defimplementation swank-compile-file (filename load-p external-format) + (with-compilation-hooks () + (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))) + (unwind-protect + (with-open-file (file tmpname :direction :output :if-exists :error) + (funcall fn file tmpname)) + (delete-file tmpname)))) + +(defun compile-from-temp-file (string) + (call-with-temp-file + (lambda (stream filename) + (write-string string stream) + (finish-output stream) + (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)))))) + +(defimplementation swank-compile-string (string &key buffer position directory) + ;; We store the source buffer in excl::*source-pathname* as a string + ;; of the form <buffername>;<start-offset>. Quite ugly encoding, but + ;; the fasl file is corrupted if we use some other datatype. + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string) + (*default-pathname-defaults* + (if directory (merge-pathnames (pathname directory)) + *default-pathname-defaults*))) + (compile-from-temp-file + (format nil "~S ~S~%~A" + `(in-package ,(package-name *package*)) + `(eval-when (:compile-toplevel :load-toplevel) + (setq excl::*source-pathname* + ',(format nil "~A;~D" buffer position))) + string))))) + +;;;; Definition Finding + +(defun fspec-primary-name (fspec) + (etypecase fspec + (symbol fspec) + (list (fspec-primary-name (second fspec))))) + +;; If Emacs uses DOS-style eol conventions, \n\r are considered as a +;; single character, but file-position counts them as two. Here we do +;; our own conversion. +(defun count-cr (file pos) + (let* ((bufsize 256) + (type '(unsigned-byte 8)) + (buf (make-array bufsize :element-type type)) + (cr-count 0)) + (with-open-file (stream file :direction :input :element-type type) + (loop for bytes-read = (read-sequence buf stream) do + (incf cr-count (count (char-code #\return) buf + :end (min pos bytes-read))) + (decf pos bytes-read) + (when (<= pos 0) + (return cr-count)))))) + +(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)))))) + (make-location (list :file (namestring (truename file))) + pos))) + +(defun find-definition-in-buffer (filename) + (let ((pos (position #; filename :from-end t))) + (make-location + (list :buffer (subseq filename 0 pos)) + (list :position (parse-integer (subseq filename (1+ pos))))))) + +(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 + (symbol (let ((*package* (find-package :keyword))) + (prin1-to-string fspec))) + (list (format nil "(~A ~A)" + (prin1-to-string (first fspec)) + (let ((*package* (find-package :keyword))) + (prin1-to-string (second fspec))))))) + +(defun fspec-definition-locations (fspec) + (cond + ((and (listp fspec) + (eql (car fspec) :top-level-form)) + (destructuring-bind (top-level-form file &optional 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)) + +;;;; XREF + +(defmacro defxref (name relation name1 name2) + `(defimplementation ,name (x) + (xref-result (xref:get-relation ,relation ,name1 ,name2)))) + +(defxref who-calls :calls :wild x) +(defxref calls-who :calls x :wild) +(defxref who-references :uses :wild x) +(defxref who-binds :binds :wild x) +(defxref who-macroexpands :macro-calls :wild x) +(defxref who-sets :sets :wild x) + +(defun xref-result (fspecs) + (loop for fspec in fspecs + append (fspec-definition-locations fspec))) + +;; list-callers implemented by groveling through all fbound symbols. +;; Only symbols are considered. Functions in the constant pool are +;; searched recursively. Closure environments are ignored at the +;; moment (constants in methods are therefore not found). + +(defun map-function-constants (function fn depth) + "Call FN with the elements of FUNCTION's constant pool." + (do ((i 0 (1+ i)) + (max (excl::function-constant-count function))) + ((= i max)) + (let ((c (excl::function-constant function i))) + (cond ((and (functionp c) + (not (eq c function)) + (plusp depth)) + (map-function-constants c fn (1- depth))) + (t + (funcall fn c)))))) + +(defun in-constants-p (fun symbol) + (map-function-constants fun + (lambda (c) + (when (eq c symbol) + (return-from in-constants-p t))) + 3)) + +(defun function-callers (name) + (let ((callers '())) + (do-all-symbols (sym) + (when (fboundp sym) + (let ((fn (fdefinition sym))) + (when (in-constants-p fn name) + (push sym callers))))) + callers)) + +(defimplementation list-callers (name) + (xref-result (function-callers name))) + +(defimplementation list-callees (name) + (let ((result '())) + (map-function-constants (fdefinition name) + (lambda (c) + (when (fboundp c) + (push c result))) + 2) + (xref-result result))) + +;;;; Profiling + +;; Per-function profiling based on description in +;; http://www.franz.com/support/documentation/8.0/doc/runtime-analyzer.htm#data... + +(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 (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'acl-inspector)) + +(defmethod inspect-for-emacs ((f function) inspector) + inspector + (values "A function." + (append + (label-value-line "Name" (function-name f)) + `("Formals" ,(princ-to-string (arglist f)) (:newline)) + (let ((doc (documentation (excl::external-fn_symdef f) 'function))) + (when doc + `("Documentation:" (:newline) ,doc)))))) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + inspector + (values "A value." (allegro-inspect o))) + +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) + inspector + (values "A function." (allegro-inspect o))) + +(defmethod inspect-for-emacs ((o standard-object) + (inspector backend-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) + until (eq d dd))) + +(defun frob-allegro-field-def (object def) + (with-struct (inspect::field-def- name type access) def + (ecase type + ((:unsigned-word :unsigned-byte :unsigned-natural + :unsigned-long :unsigned-half-long + :unsigned-3byte) + (label-value-line name (inspect::component-ref-v object access type))) + ((:lisp :value) + (label-value-line name (inspect::component-ref object access))) + (:indirect + (destructuring-bind (prefix count ref set) access + (declare (ignore set prefix)) + (loop for i below (funcall count object) + append (label-value-line (format nil "~A-~D" name i) + (funcall ref object i)))))))) + +;;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (mp:start-scheduler) + (funcall continuation)) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + +(defvar *id-lock* (mp:make-process-lock :name "id lock")) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-process-lock (*id-lock*) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id mp:*all-processes* + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A ~D" (mp:process-whostate thread) + (mp:process-priority thread))) + +(defimplementation make-lock (&key name) + (mp:make-process-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-process-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (copy-list mp:*all-processes*)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock")) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-process-lock :name "process mailbox")) + (queue '() :type list)) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-process-lock (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (mp:process-wait-with-timeout + "yielding before sending" 0.1 + (lambda () + (mp:with-process-lock (mutex) + (< (length (mailbox.queue mbox)) 10)))) + (mp:with-process-lock (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(defimplementation receive () + (let* ((mbox (mailbox mp:*current-process*)) + (mutex (mailbox.mutex mbox))) + (mp:process-wait "receive" #'mailbox.queue mbox) + (mp:with-process-lock (mutex) + (pop (mailbox.queue mbox))))) + +(defimplementation quit-lisp () + (excl:exit 0 :quiet t)) + + +;;Trace implementations +;;In Allegro 7.0, we have: +;; (trace <name>) +;; (trace ((method <name> <qualifier>? (<specializer>+)))) +;; (trace ((labels <name> <label-name>))) +;; (trace ((labels (method <name> (<specializer>+)) <label-name>))) +;; <name> can be a normal name or a (setf name) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + (:defgeneric (toggle-trace-generic-function-methods (second spec))) + ((setf :defmethod :labels :flet) + (toggle-trace-aux (process-fspec-for-allegro spec))) + (:call + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee + :inside (list (process-fspec-for-allegro caller))))))) + +(defun tracedp (fspec) + (member fspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((tracedp fspec) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace (,fspec ,@args))) + (format nil "~S is now traced." fspec)))) + +(defun toggle-trace-generic-function-methods (name) + (let ((methods (mop:generic-function-methods (fdefinition name)))) + (cond ((tracedp name) + (eval `(untrace ,name)) + (dolist (method methods (format nil "~S is now untraced." name)) + (excl:funtrace (mop:method-function method)))) + (t + (eval `(trace (,name))) + (dolist (method methods (format nil "~S is now traced." name)) + (excl:ftrace (mop:method-function method))))))) + +(defun process-fspec-for-allegro (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((setf) fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))) + ((:flet) `(flet ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))))) + (t + fspec))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-keys t args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :values :weak args)) + +(defimplementation hash-table-weakness (hashtable) + (cond ((excl:hash-table-weak-keys hashtable) :key) + ((eq (excl:hash-table-values hashtable) :weak) :value))) + + + +;;;; Character names + +(defimplementation character-completion-set (prefix matchp) + (loop for name being the hash-keys of excl::*name-to-char-table* + when (funcall matchp prefix name) + collect (string-capitalize name)))
Added: branches/trunk-reorg/thirdparty/slime/swank-backend.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-backend.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-backend.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,1077 @@ +;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- +;;; +;;; slime-backend.lisp --- SLIME backend interface. +;;; +;;; Created by James Bielman in 2003. Released into the public domain. +;;; +;;;; Frontmatter +;;; +;;; This file defines the functions that must be implemented +;;; separately for each Lisp. Each is declared as a generic function +;;; for which swank-<implementation>.lisp provides methods. + +(defpackage :swank-backend + (:use :common-lisp) + (:export #:sldb-condition + #:original-condition + #:compiler-condition + #:message + #:short-message + #:condition + #:severity + #:with-compilation-hooks + #:location + #:location-p + #:location-buffer + #:location-position + #:position-p + #:position-pos + #:print-output-to-string + #:quit-lisp + #:references + #:unbound-slot-filler + #:declaration-arglist + #:type-specifier-arglist + ;; inspector related symbols + #:inspector + #:backend-inspector + #:inspect-for-emacs + #:raw-inspection + #:fancy-inspection + #:label-value-line + #:label-value-line* + #:with-struct + )) + +(defpackage :swank-mop + (:use) + (:export + ;; classes + #:standard-generic-function + #:standard-slot-definition + #:standard-method + #:standard-class + #:eql-specializer + #:eql-specializer-object + ;; standard-class readers + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-name + #:class-precedence-list + #:class-prototype + #:class-slots + #:specializer-direct-methods + ;; generic function readers + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-methods + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-name + ;; method readers + #:method-generic-function + #:method-function + #:method-lambda-list + #:method-specializers + #:method-qualifiers + ;; slot readers + #:slot-definition-allocation + #:slot-definition-documentation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-name + #:slot-definition-type + #:slot-definition-readers + #:slot-definition-writers + #:slot-boundp-using-class + #:slot-value-using-class + #:slot-makunbound-using-class + ;; generic function protocol + #:compute-applicable-methods-using-classes + #:finalize-inheritance)) + +(in-package :swank-backend) + + +;;;; Metacode + +(defparameter *interface-functions* '() + "The names of all interface functions.") + +(defparameter *unimplemented-interfaces* '() + "List of interface functions that are not implemented. +DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.") + +(defmacro definterface (name args documentation &rest default-body) + "Define an interface function for the backend to implement. +A function is defined with NAME, ARGS, and DOCUMENTATION. This +function first looks for a function to call in NAME's property list +that is indicated by 'IMPLEMENTATION; failing that, it looks for a +function indicated by 'DEFAULT. If neither is present, an error is +signaled. + +If a DEFAULT-BODY is supplied, then a function with the same body and +ARGS will be added to NAME's property list as the property indicated +by 'DEFAULT. + +Backends implement these functions using DEFIMPLEMENTATION." + (check-type documentation string "a documentation string") + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + (labels ((gen-default-impl () + `(setf (get ',name 'default) (lambda ,args ,@default-body))) + (args-as-list (args) + (destructuring-bind (req opt key rest) (parse-lambda-list args) + `(,@req ,@opt + ,@(loop for k in key append `(,(kw k) ,k)) + ,@(or rest '(()))))) + (parse-lambda-list (args) + (parse args '(&optional &key &rest) + (make-array 4 :initial-element nil))) + (parse (args keywords vars) + (cond ((null args) + (reverse (map 'list #'reverse vars))) + ((member (car args) keywords) + (parse (cdr args) (cdr (member (car args) keywords)) vars)) + (t (push (car args) (aref vars (length keywords))) + (parse (cdr args) keywords vars)))) + (kw (s) (intern (string s) :keyword))) + `(progn + (defun ,name ,args + ,documentation + (let ((f (or (get ',name 'implementation) + (get ',name 'default)))) + (cond (f (apply f ,@(args-as-list args))) + (t (error "~S not 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/s_cltl1-compile-file-toplevel-compatibility-p_s.htm + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name :swank-backend)) + ',name))) + +(defmacro defimplementation (name args &body body) + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + `(progn + (setf (get ',name 'implementation) (lambda ,args ,@body)) + (if (member ',name *interface-functions*) + (setq *unimplemented-interfaces* + (remove ',name *unimplemented-interfaces*)) + (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name)) + ',name)) + +(defun warn-unimplemented-interfaces () + "Warn the user about unimplemented backend features. +The portable code calls this function at startup." + (warn "These Swank interfaces are unimplemented:~% ~A" + (sort (copy-list *unimplemented-interfaces*) #'string<))) + +(defun import-to-swank-mop (symbol-list) + (dolist (sym symbol-list) + (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop))) + (when swank-mop-sym + (unintern swank-mop-sym :swank-mop)) + (import sym :swank-mop) + (export sym :swank-mop)))) + +(defun import-swank-mop-symbols (package except) + "Import the mop symbols from PACKAGE to SWANK-MOP. +EXCEPT is a list of symbol names which should be ignored." + (do-symbols (s :swank-mop) + (unless (member s except :test #'string=) + (let ((real-symbol (find-symbol (string s) package))) + (assert real-symbol () "Symbol ~A not found in package ~A" s package) + (unintern s :swank-mop) + (import real-symbol :swank-mop) + (export real-symbol :swank-mop))))) + +(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 + +(defmacro with-struct ((conc-name &rest names) obj &body body) + "Like with-slots but works only for structs." + (flet ((reader (slot) (intern (concatenate 'string + (symbol-name conc-name) + (symbol-name slot)) + (symbol-package conc-name)))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + + +;;;; TCP server + +(definterface create-socket (host port) + "Create a listening TCP socket on interface HOST and port PORT .") + +(definterface local-port (socket) + "Return the local port number of SOCKET.") + +(definterface close-socket (socket) + "Close the socket SOCKET.") + +(definterface accept-connection (socket &key external-format + buffering timeout) + "Accept a client connection on the listening socket SOCKET. +Return a stream for the new connection.") + +(definterface add-sigio-handler (socket fn) + "Call FN whenever SOCKET is readable.") + +(definterface remove-sigio-handlers (socket) + "Remove all sigio handlers for SOCKET.") + +(definterface add-fd-handler (socket fn) + "Call FN when Lisp is waiting for input and SOCKET is readable.") + +(definterface remove-fd-handlers (socket) + "Remove all fd-handlers for SOCKET.") + +(definterface preferred-communication-style () + "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL." + nil) + +(definterface set-stream-timeout (stream timeout) + "Set the 'stream 'timeout. The timeout is either the real number + specifying the timeout in seconds or 'nil for no timeout." + (declare (ignore stream timeout)) + nil) + +;;; Base condition for networking errors. +(define-condition network-error (simple-error) ()) + +(definterface emacs-connected () + "Hook called when the first connection from Emacs is established. +Called from the INIT-FN of the socket server that accepts the +connection. + +This is intended for setting up extra context, e.g. to discover +that the calling thread is the one that interacts with Emacs." + nil) + + +;;;; Unix signals + +(defconstant +sigint+ 2) + +(definterface call-without-interrupts (fn) + "Call FN in a context where interrupts are disabled." + (funcall fn)) + +(definterface getpid () + "Return the (Unix) process ID of this superior Lisp.") + +(definterface lisp-implementation-type-name () + "Return a short name for the Lisp implementation." + (lisp-implementation-type)) + +(definterface default-directory () + "Return the default directory." + (directory-namestring (truename *default-pathname-defaults*))) + +(definterface set-default-directory (directory) + "Set the default directory. +This is used to resolve filenames without directory component." + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (default-directory)) + +(definterface call-with-syntax-hooks (fn) + "Call FN with hooks to handle special syntax." + (funcall fn)) + +(definterface default-readtable-alist () + "Return a suitable initial value for SWANK:*READTABLE-ALIST*." + '()) + +(definterface quit-lisp () + "Exit the current lisp image.") + + +;;;; Compilation + +(definterface call-with-compilation-hooks (func) + "Call FUNC with hooks to record compiler conditions.") + +(defmacro with-compilation-hooks ((&rest ignore) &body body) + "Execute BODY as in CALL-WITH-COMPILATION-HOOKS." + (declare (ignore ignore)) + `(call-with-compilation-hooks (lambda () (progn ,@body)))) + +(definterface swank-compile-string (string &key buffer position directory) + "Compile source from STRING. During compilation, compiler +conditions must be trapped and resignalled as COMPILER-CONDITIONs. + +If supplied, BUFFER and POSITION specify the source location in Emacs. + +Additionally, if POSITION is supplied, it must be added to source +positions reported in compiler conditions. + +If DIRECTORY is specified it may be used by certain implementations to +rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of +source information.") + +(definterface swank-compile-file (filename load-p external-format) + "Compile FILENAME signalling COMPILE-CONDITIONs. +If LOAD-P is true, load the file after compilation. +EXTERNAL-FORMAT is a value returned by find-external-format or +:default.") + +(deftype severity () + '(member :error :read-error :warning :style-warning :note)) + +;; Base condition type for compiler errors, warnings and notes. +(define-condition compiler-condition (condition) + ((original-condition + ;; The original condition thrown by the compiler if appropriate. + ;; May be NIL if a compiler does not report using conditions. + :type (or null condition) + :initarg :original-condition + :accessor original-condition) + + (severity :type severity + :initarg :severity + :accessor severity) + + (message :initarg :message + :accessor message) + + (short-message :initarg :short-message + :initform nil + :accessor short-message) + + (references :initarg :references + :initform nil + :accessor references) + + (location :initarg :location + :accessor location))) + +(definterface find-external-format (coding-system) + "Return a "external file format designator" for CODING-SYSTEM. +CODING-SYSTEM is Emacs-style coding system name (a string), +e.g. "latin-1-unix"." + (if (equal coding-system "iso-latin-1-unix") + :default + nil)) + +(definterface guess-external-format (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)) + (if s + (or (let* ((line (read-line s nil)) + (p (search "-*-" line))) + (when p + (let* ((start (+ p (length "-*-"))) + (end (search "-*-" line :start2 start))) + (when end + (%search-coding line start end))))) + (let* ((len (file-length s)) + (buf (make-string (min len 3000)))) + (file-position s (- len (length buf))) + (read-sequence buf s) + (let ((start (search "Local Variables:" buf :from-end t)) + (end (search "End:" buf :from-end t))) + (and start end (< start end) + (%search-coding buf start end)))))))) + +(defun %search-coding (str start end) + (let ((p (search "coding:" str :start2 start :end2 end))) + (when p + (incf p (length "coding:")) + (loop while (and (< p end) + (member (aref str p) '(#\space #\tab))) + do (incf p)) + (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline))) + str :start p))) + (find-external-format (subseq str p end)))))) + + +;;;; Streams + +(definterface make-fn-streams (input-fn output-fn) + "Return character input and output streams backended by functions. +When input is needed, INPUT-FN is called with no arguments to +return a string. +When output is ready, OUTPUT-FN is called with the output as its +argument. + +Output should be forced to OUTPUT-FN before calling INPUT-FN. + +The streams are returned as two values.") + +(definterface make-stream-interactive (stream) + "Do any necessary setup to make STREAM work interactively. +This is called for each stream used for interaction with the user +(e.g. *standard-output*). An implementation could setup some +implementation-specific functions to control output flushing at the +like." + (declare (ignore stream)) + nil) + + +;;;; Documentation + +(definterface arglist (name) + "Return the lambda list for the symbol NAME. NAME can also be +a lisp function object, on lisps which support this. + +The result can be a list or the :not-available keyword if the +arglist cannot be determined." + (declare (ignore name)) + :not-available) + +(defgeneric declaration-arglist (decl-identifier) + (:documentation + "Return the argument list of the declaration specifier belonging to the +declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined, +the keyword :NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (decl-identifier) + (case decl-identifier + (dynamic-extent '(&rest vars)) + (ignore '(&rest vars)) + (ignorable '(&rest vars)) + (special '(&rest vars)) + (inline '(&rest function-names)) + (notinline '(&rest function-name)) + (optimize '(&any compilation-speed debug safety space speed)) + (type '(type-specifier &rest args)) + (ftype '(type-specifier &rest function-names)) + (otherwise + (flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol)))) + (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier)) + '(&rest vars)) + ((and (listp decl-identifier) (typespec-p (first decl-identifier))) + '(&rest vars)) + (t :not-available))))))) + +(defgeneric type-specifier-arglist (typespec-operator) + (:documentation + "Return the argument list of the type specifier belonging to +TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword +:NOT-AVAILABLE is returned. + +The different SWANK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (typespec-operator) + (declare (special *type-specifier-arglists*)) ; defined at end of file. + (typecase typespec-operator + (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*)) + :not-available)) + (t :not-available)))) + +(definterface function-name (function) + "Return the name of the function object FUNCTION. + +The result is either a symbol, a list, or NIL if no function name is available." + (declare (ignore function)) + nil) + +(definterface macroexpand-all (form) + "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 :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 (but +slime-print-apropos in Emacs must know about them). + +Properties should be included if and only if they are applicable to +the symbol. For example, only (and all) fbound symbols should include +the :FUNCTION property. + +Example: +(describe-symbol-for-emacs 'vector) + => (:CLASS :NOT-DOCUMENTED + :TYPE :NOT-DOCUMENTED + :FUNCTION "Constructs a simple-vector from the given objects.")") + +(definterface describe-definition (name type) + "Describe the definition NAME of TYPE. +TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS. + +Return a documentation string, or NIL if none is available.") + + +;;;; Debugging + +(definterface install-debugger-globally (function) + "Install FUNCTION as the debugger for all threads/processes. This +usually involves setting *DEBUGGER-HOOK* and, if the implementation +permits, hooking into BREAK as well." + (setq *debugger-hook* function)) + +(definterface call-with-debugging-environment (debugger-loop-fn) + "Call DEBUGGER-LOOP-FN in a suitable debugging environment. + +This function is called recursively at each debug level to invoke the +debugger loop. The purpose is to setup any necessary environment for +other debugger callbacks that will be called within the debugger loop. + +For example, this is a reasonable place to compute a backtrace, switch +to safe reader/printer settings, and so on.") + +(definterface call-with-debugger-hook (hook fun) + "Call FUN and use HOOK as debugger hook. + +HOOK should be called for both BREAK and INVOKE-DEBUGGER." + (let ((*debugger-hook* hook)) + (funcall fun))) + +(define-condition sldb-condition (condition) + ((original-condition + :initarg :original-condition + :accessor original-condition)) + (:report (lambda (condition stream) + (format stream "Condition in debugger code~@[: ~A~]" + (original-condition condition)))) + (:documentation + "Wrapper for conditions that should not be debugged. + +When a condition arises from the internals of the debugger, it is not +desirable to debug it -- we'd risk entering an endless loop trying to +debug the debugger! Instead, such conditions can be reported to the +user without (re)entering the debugger by wrapping them as +`sldb-condition's.")) + +(definterface compute-backtrace (start end) + "Return a list containing a backtrace of the condition current +being debugged. The results are unspecified if this function is +called outside the dynamic contour CALL-WITH-DEBUGGING-ENVIRONMENT. + +START and END are zero-based indices constraining the number of frames +returned. Frame zero is defined as the frame which invoked the +debugger. If END is nil, return the frames from START to the end of +the stack.") + +(definterface compute-sane-restarts (condition) + "This is an opportunity for Lisps such as CLISP to remove +unwanted restarts from the output of CL:COMPUTE-RESTARTS, +otherwise it should simply call CL:COMPUTE-RESTARTS, which is +what the default implementation does." + (compute-restarts condition)) + +(definterface print-frame (frame stream) + "Print frame to stream.") + +(definterface frame-source-location-for-emacs (frame-number) + "Return the source location for FRAME-NUMBER.") + +(definterface frame-catch-tags (frame-number) + "Return a list of XXX list of what? catch tags for a debugger +stack frame. The results are undefined unless this is called +within the dynamic contour of a function defined by +DEFINE-DEBUGGER-HOOK.") + +(definterface frame-locals (frame-number) + "Return a list of XXX local variable designators define me +for a debugger stack frame. The results are undefined unless +this is called within the dynamic contour of a function defined +by DEFINE-DEBUGGER-HOOK.") + +(definterface frame-var-value (frame var) + "Return the value of VAR in FRAME. +FRAME is the number of the frame in the backtrace. +VAR is the number of the variable in the frame.") + +(definterface disassemble-frame (frame-number) + "Disassemble the code for the FRAME-NUMBER. +The output should be written to standard output. +FRAME-NUMBER is a non-negative integer.") + +(definterface eval-in-frame (form frame-number) + "Evaluate a Lisp form in the lexical context of a stack frame +in the debugger. The results are undefined unless called in the +dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK. + +FRAME-NUMBER must be a positive integer with 0 indicating the +frame which invoked the debugger. + +The return value is the result of evaulating FORM in the +appropriate context.") + +(definterface return-from-frame (frame-number form) + "Unwind the stack to the frame FRAME-NUMBER and return the value(s) +produced by evaluating FORM in the frame context to its caller. + +Execute any clean-up code from unwind-protect forms above the frame +during unwinding. + +Return a string describing the error if it's not possible to return +from the frame.") + +(definterface restart-frame (frame-number) + "Restart execution of the frame FRAME-NUMBER with the same arguments +as it was called originally.") + +(definterface format-sldb-condition (condition) + "Format a condition for display in SLDB." + (princ-to-string condition)) + +(definterface condition-extras (condition) + "Return a list of extra for the debugger. +The allowed elements are of the form: + (:SHOW-FRAME-SOURCE frame-number) + (:REFERENCES &rest refs) +" + (declare (ignore condition)) + '()) + +(definterface activate-stepping (frame-number) + "Prepare the frame FRAME-NUMBER for stepping.") + +(definterface sldb-break-on-return (frame-number) + "Set a breakpoint in the frame FRAME-NUMBER.") + +(definterface sldb-break-at-start (symbol) + "Set a breakpoint on the beginning of the function for SYMBOL.") + +(definterface sldb-stepper-condition-p (condition) + "Return true if SLDB was invoked due to a single-stepping condition, +false otherwise. " + (declare (ignore condition)) + nil) + +(definterface sldb-step-into () + "Step into the current single-stepper form.") + +(definterface sldb-step-next () + "Step to the next form in the current function.") + +(definterface sldb-step-out () + "Stop single-stepping temporarily, but resume it once the current function +returns.") + + +;;;; Definition finding + +(defstruct (:location (:type list) :named + (:constructor make-location + (buffer position &optional hints))) + buffer position + ;; Hints is a property list optionally containing: + ;; :snippet SOURCE-TEXT + ;; This is a snippet of the actual source text at the start of + ;; the definition, which could be used in a text search. + hints) + +(defstruct (:error (:type list) :named (:constructor)) message) +(defstruct (:file (:type list) :named (:constructor)) name) +(defstruct (:buffer (:type list) :named (:constructor)) name) +(defstruct (:position (:type list) :named (:constructor)) pos) + +(definterface find-definitions (name) + "Return a list ((DSPEC LOCATION) ...) for NAME's definitions. + +NAME is a "definition specifier". + +DSPEC is a "definition specifier" describing the +definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or +(DEFVAR FOO). + +LOCATION is the source location for the definition.") + +(definterface buffer-first-change (filename) + "Called for effect the first time FILENAME's buffer is modified." + (declare (ignore filename)) + nil) + + +;;;; XREF + +(definterface who-calls (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...).") + +(definterface calls-who (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...).") + +(definterface who-references (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is referenced. +See WHO-CALLS for a description of the return value.") + +(definterface who-binds (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is bound. +See WHO-CALLS for a description of the return value.") + +(definterface who-sets (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is set. +See WHO-CALLS for a description of the return value.") + +(definterface who-macroexpands (macro-name) + "Return the locations where MACRO-NAME (a symbol) is expanded. +See WHO-CALLS for a description of the return value.") + +(definterface who-specializes (class-name) + "Return the locations where CLASS-NAME (a symbol) is specialized. +See WHO-CALLS for a description of the return value.") + +;;; Simpler variants. + +(definterface list-callers (function-name) + "List the callers of FUNCTION-NAME. +This function is like WHO-CALLS except that it is expected to use +lower-level means. Whereas WHO-CALLS is usually implemented with +special compiler support, LIST-CALLERS is usually implemented by +groveling for constants in function objects throughout the heap. + +The return value is as for WHO-CALLS.") + +(definterface list-callees (function-name) + "List the functions called by FUNCTION-NAME. +See LIST-CALLERS for a description of the return value.") + + +;;;; Profiling + +;;; The following functions define a minimal profiling interface. + +(definterface profile (fname) + "Marks symbol FNAME for profiling.") + +(definterface profiled-functions () + "Returns a list of profiled functions.") + +(definterface unprofile (fname) + "Marks symbol FNAME as not profiled.") + +(definterface unprofile-all () + "Marks all currently profiled functions as not profiled." + (dolist (f (profiled-functions)) + (unprofile f))) + +(definterface profile-report () + "Prints profile report.") + +(definterface profile-reset () + "Resets profile counters.") + +(definterface profile-package (package callers-p methods) + "Wrap profiling code around all functions in PACKAGE. If a function +is already profiled, then unprofile and reprofile (useful to notice +function redefinition.) + +If CALLERS-P is T names have counts of the most common calling +functions recorded. + +When called with arguments :METHODS T, profile all methods of all +generic functions having names in the given package. Generic functions +themselves, that is, their dispatch functions, are left alone.") + + +;;;; Inspector + +(defclass inspector () + () + (:documentation "Super class of inspector objects. + +Implementations should sub class in order to dispatch off of the +inspect-for-emacs method.")) + +(defclass backend-inspector (inspector) ()) + +(definterface make-default-inspector () + "Return an inspector object suitable for passing to inspect-for-emacs.") + +(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 +class used simply for dispatching to the proper method. + +Returns two values: a string which will be used as the title of +the inspector buffer and a list specifying how to render the +object for inspection. + +Every element of the list must be either a string, which will be +inserted into the buffer as is, or a list of the form: + + (:value object &optional format) - Render an inspectable + object. If format is provided it must be a string and will be + rendered in place of the value, otherwise use princ-to-string. + + (:newline) - Render a \n + + (:action label lambda &key (refresh t)) - Render LABEL (a text + string) which when clicked will call LAMBDA. If REFRESH is + non-NIL the currently inspected object will be re-inspected + after calling the lambda. + + NIL - do nothing.")) + +(defmethod inspect-for-emacs ((object t) (inspector t)) + "Generic method for inspecting any kind of object. + +Since we don't know how to deal with OBJECT we simply dump the +output of CL:DESCRIBE." + (declare (ignore inspector)) + (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. +;;; +(defun label-value-line (label value &key (newline t)) + "Create a control list which prints "LABEL: VALUE" in the inspector. +If NEWLINE is non-NIL a `(:newline)' is added to the result." + (list* (princ-to-string label) ": " `(:value ,value) + (if newline '((:newline)) nil))) + +(defmacro label-value-line* (&rest label-values) + ` (append ,@(loop for (label value) in label-values + collect `(label-value-line ,label ,value)))) + +(definterface describe-primitive-type (object) + "Return a string describing the primitive type of object." + (declare (ignore object)) + "N/A") + + +;;;; Multithreading +;;; +;;; The default implementations are sufficient for non-multiprocessing +;;; implementations. + +(definterface initialize-multiprocessing (continuation) + "Initialize multiprocessing, if necessary and then invoke CONTINUATION. + +Depending on the impleimentaion, this function may never return." + (funcall continuation)) + +(definterface spawn (fn &key name) + "Create a new thread to call FN.") + +(definterface thread-id (thread) + "Return an Emacs-parsable object to identify THREAD. + +Ids should be comparable with equal, i.e.: + (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)") + +(definterface find-thread (id) + "Return the thread for ID. +ID should be an id previously obtained with THREAD-ID. +Can return nil if the thread no longer exists.") + +(definterface thread-name (thread) + "Return the name of THREAD. + +Thread names are be single-line strings and are meaningful to the +user. They do not have to be unique." + (declare (ignore thread)) + "The One True Thread") + +(definterface thread-status (thread) + "Return a string describing THREAD's state." + (declare (ignore thread)) + "") + +(definterface make-lock (&key name) + "Make a lock for thread synchronization. +Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time." + (declare (ignore name)) + :null-lock) + +(definterface call-with-lock-held (lock function) + "Call FUNCTION with LOCK held, queueing if necessary." + (declare (ignore lock) + (type function function)) + (funcall function)) + +(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) + +(definterface all-threads () + "Return a list of all threads.") + +(definterface thread-alive-p (thread) + "Test if THREAD is termintated." + (member thread (all-threads))) + +(definterface interrupt-thread (thread fn) + "Cause THREAD to execute FN.") + +(definterface kill-thread (thread) + "Kill THREAD." + (declare (ignore thread)) + nil) + +(definterface send (thread object) + "Send OBJECT to thread THREAD.") + +(definterface receive () + "Return the next message from current thread's mailbox.") + +(definterface toggle-trace (spec) + "Toggle tracing of the function(s) given with SPEC. +SPEC can be: + (setf NAME) ; a setf function + (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method + (:defgeneric NAME) ; a generic function with all methods + (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. + (:labels TOPLEVEL LOCAL) + (:flet TOPLEVEL LOCAL) ") + + +;;;; Weak datastructures + +(definterface make-weak-key-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the keys." + (apply #'make-hash-table args)) + +(definterface make-weak-value-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the values." + (apply #'make-hash-table args)) + +(definterface hash-table-weakness (hashtable) + "Return nil or one of :key :value :key-or-value :key-and-value" + (declare (ignore hashtable)) + nil) + + +;;;; Character names + +(definterface character-completion-set (prefix matchp) + "Return a list of names of characters that match PREFIX." + ;; Handle the standard and semi-standard characters. + (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout" + "Linefeed" "Return" "Backspace") + when (funcall matchp prefix name) + collect name)) + + +(defparameter *type-specifier-arglists* + '((and . (&rest type-specifiers)) + (array . (&optional element-type dimension-spec)) + (base-string . (&optional size)) + (bit-vector . (&optional size)) + (complex . (&optional type-specifier)) + (cons . (&optional car-typespec cdr-typespec)) + (double-float . (&optional lower-limit upper-limit)) + (eql . (object)) + (float . (&optional lower-limit upper-limit)) + (function . (&optional arg-typespec value-typespec)) + (integer . (&optional lower-limit upper-limit)) + (long-float . (&optional lower-limit upper-limit)) + (member . (&rest eql-objects)) + (mod . (n)) + (not . (type-specifier)) + (or . (&rest type-specifiers)) + (rational . (&optional lower-limit upper-limit)) + (real . (&optional lower-limit upper-limit)) + (satisfies . (predicate-symbol)) + (short-float . (&optional lower-limit upper-limit)) + (signed-byte . (&optional size)) + (simple-array . (&optional element-type dimension-spec)) + (simple-base-string . (&optional size)) + (simple-bit-vector . (&optional size)) + (simple-string . (&optional size)) + (single-float . (&optional lower-limit upper-limit)) + (simple-vector . (&optional size)) + (string . (&optional size)) + (unsigned-byte . (&optional size)) + (values . (&rest typespecs)) + (vector . (&optional element-type size)) + ))
Added: branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,672 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +;;;; SWANK support for CLISP. + +;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach + +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License as +;;;; published by the Free Software Foundation; either version 2 of +;;;; the License, or (at your option) any later version. + +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. + +;;;; You should have received a copy of the GNU General Public +;;;; License along with this program; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;;;; MA 02111-1307, USA. + +;;; This is work in progress, but it's already usable. Many things +;;; are adapted from other swank-*.lisp, in particular from +;;; swank-allegro (I don't use allegro at all, but it's the shortest +;;; one and I found Helmut Eller's code there enlightening). + +;;; This code will work better with recent versions of CLISP (say, the +;;; last release or CVS HEAD) while it may not work at all with older +;;; versions. It is reasonable to expect it to work on platforms with +;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like +;;; systems, but also on Win32. This backend uses the portable xref +;;; from the CMU AI repository and metering.lisp from CLOCC [1], which +;;; are conveniently included in SLIME. + +;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/ + +(in-package :swank-backend) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;(use-package "SOCKET") + (use-package "GRAY")) + +;;;; if this lisp has the complete CLOS then we use it, otherwise we +;;;; build up a "fake" swank-mop and then override the methods in the +;;;; inspector. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *have-mop* + (and (find-package :clos) + (eql :external + (nth-value 1 (find-symbol (string ':standard-slot-definition) + :clos)))) + "True in those CLISP images which have a complete MOP implementation.")) + +#+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or)) +(progn + (import-swank-mop-symbols :clos '(:slot-definition-documentation)) + + (defun swank-mop:slot-definition-documentation (slot) + (clos::slot-definition-documentation slot))) + +#-#.(cl:if swank-backend::*have-mop* '(and) '(or)) +(defclass swank-mop:standard-slot-definition () + () + (:documentation + "Dummy class created so that swank.lisp will compile and load.")) + +;; #+#.(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))))) + +;; (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)) + +(let ((getpid (or (find-symbol "PROCESS-ID" :system) + ;; old name prior to 2005-03-01, clisp <= 2.33.2 + (find-symbol "PROGRAM-ID" :system) + #+win32 ; integrated into the above since 2005-02-24 + (and (find-package :win32) ; optional modules/win32 + (find-symbol "GetCurrentProcessId" :win32))))) + (defimplementation getpid () ; a required interface + (cond + (getpid (funcall getpid)) + #+win32 ((ext:getenv "PID")) ; where does that come from? + (t -1)))) + +(defimplementation lisp-implementation-type-name () + "clisp") + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) directory) + (namestring (setf *default-pathname-defaults* (ext:default-directory)))) + +;;;; TCP Server + +(defimplementation create-socket (host port) + (declare (ignore host)) + (socket:socket-server port)) + +(defimplementation local-port (socket) + (socket:socket-server-port socket)) + +(defimplementation close-socket (socket) + (socket:socket-server-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (socket:socket-accept socket + :buffered nil ;; XXX should be t + :element-type 'character + :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 + (let ((exp (function-lambda-expression fname))) + (and exp (return (second exp))))) + (ignore-errors + (return (ext:arglist fname))) + :not-available))) + +(defimplementation macroexpand-all (form) + (ext:expand-form form)) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result ())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push :variable (when (boundp symbol) (doc 'variable))) + (when (fboundp symbol) + (maybe-push + ;; Report WHEN etc. as macros, even though they may be + ;; implemented as special operators. + (if (macro-function symbol) :macro + (typecase (fdefinition symbol) + (generic-function :generic-function) + (function :function) + ;; (type-of 'progn) -> ext:special-operator + (t :special-operator))) + (doc 'function))) + (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt) + (get symbol 'system::setf-expander)); defsetf + (maybe-push :setf (doc 'setf))) + (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp + (get symbol 'system::defstruct-description) + (get symbol 'system::deftype-expander)) + (maybe-push :type (doc 'type))) ; even for 'structure + (when (find-class symbol nil) + (maybe-push :class (doc 'type))) + ;; Let this code work compiled in images without FFI + (let ((types (load-time-value + (and (find-package "FFI") + (symbol-value + (find-symbol "*C-TYPE-TABLE*" "FFI")))))) + ;; Use ffi::*c-type-table* so as not to suffer the overhead of + ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols + ;; which are not FFI type names. + (when (and types (nth-value 1 (gethash symbol types))) + ;; Maybe use (case (head (ffi:deparse-c-type))) + ;; to distinguish struct and union types? + (maybe-push :alien-type :not-documented))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable (describe symbol)) + (:macro (describe (macro-function symbol))) + (:function (describe (symbol-function symbol))) + (:class (describe (find-class symbol))))) + +(defun fspec-pathname (symbol) + (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) + (multiple-value-bind (file lines) + (fspec-pathname fspec) + (cond (file + (multiple-value-bind (truename c) (ignore-errors (truename file)) + (cond (truename + (make-location (list :file (namestring truename)) + (if (consp lines) + (list* :line lines) + (list :function-name (string fspec))))) + (t (list :error (princ-to-string c)))))) + (t (list :error (format nil "No source information available for: ~S" + fspec)))))) + +(defimplementation find-definitions (name) + (list (list name (fspec-location name)))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defvar *sldb-backtrace*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(sys::*break-count* (1+ sys::*break-count*)) + ;;(sys::*driver* debugger-loop-fn) + ;;(sys::*fasoutput-stream* nil) + (*sldb-backtrace* + (nthcdr 3 (member (sys::the-frame) (sldb-backtrace))))) + (funcall debugger-loop-fn))) + +(defun nth-frame (index) + (nth index *sldb-backtrace*)) + +(defun sldb-backtrace () + "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." + (do ((frames '()) + (last nil frame) + (frame (sys::the-frame) (sys::frame-up-1 frame 1))) ; 1 = "all frames" + ((eq frame last) (nreverse frames)) + (unless (boring-frame-p frame) + (push frame frames)))) + +(defun boring-frame-p (frame) + (member (frame-type frame) '(stack-value bind-var bind-env))) + +(defun frame-to-string (frame) + (with-output-to-string (s) + (sys::describe-frame s frame))) + +(defun frame-type (frame) + ;; FIXME: should bind *print-length* etc. to small values. + (frame-string-type (frame-to-string frame))) + +(defvar *frame-prefixes* + '(("frame binding variables" bind-var) + ("<1> #<compiled-function" compiled-fun) + ("<1> #<system-function" sys-fun) + ("<1> #<special-operator" special-op) + ("EVAL frame" eval) + ("APPLY frame" apply) + ("compiled tagbody frame" compiled-tagbody) + ("compiled block frame" compiled-block) + ("block frame" block) + ("nested block frame" block) + ("tagbody frame" tagbody) + ("nested tagbody frame" tagbody) + ("catch frame" catch) + ("handler frame" handler) + ("unwind-protect frame" unwind-protect) + ("driver frame" driver) + ("frame binding environments" bind-env) + ("CALLBACK frame" callback) + ("- " stack-value) + ("<1> " fun) + ("<2> " 2nd-frame))) + +(defun frame-string-type (string) + (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string)) + *frame-prefixes*))) + +(defimplementation compute-backtrace (start end) + (let* ((bt *sldb-backtrace*) + (len (length bt))) + (subseq bt start (min (or end len) len)))) + +;;; CLISP's REPL sets up an ABORT restart that kills SWANK. Here we +;;; can omit that restart so that users don't select it by mistake. +(defimplementation compute-sane-restarts (condition) + ;; The outermost restart is specified to be the last element of the + ;; list, hopefully that's our unwanted ABORT restart. + (butlast (compute-restarts condition))) + +(defimplementation print-frame (frame stream) + (let ((str (frame-to-string frame))) + ;; (format stream "~A " (frame-string-type str)) + (write-string (extract-frame-line str) + stream))) + +(defun extract-frame-line (frame-string) + (let ((s frame-string)) + (trim-whitespace + (case (frame-string-type s) + ((eval special-op) + (string-match "EVAL frame .*for form \(.*\)" s 1)) + (apply + (string-match "APPLY frame for call \(.*\)" s 1)) + ((compiled-fun sys-fun fun) + (extract-function-name s)) + (t s))))) + +(defun extract-function-name (string) + (let ((1st (car (split-frame-string string)))) + (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \(.*\)>") + 1st + 1) + (string-match (format nil "^<1>[ ~%]*\(.*\)") 1st 1) + 1st))) + +(defun split-frame-string (string) + (let ((rx (format nil "~%\(~{~A~^\|~}\)" + (mapcar #'car *frame-prefixes*)))) + (loop for pos = 0 then (1+ (regexp:match-start match)) + for match = (regexp:match rx string :start pos) + if match collect (subseq string pos (regexp:match-start match)) + else collect (subseq string pos) + while match))) + +(defun string-match (pattern string n) + (let* ((match (nth-value n (regexp:match pattern string)))) + (if match (regexp:match-string string match)))) + +(defimplementation 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)) + +(defimplementation frame-locals (frame-number) + (let ((frame (nth-frame frame-number))) + (loop for i below (%frame-count-vars frame) + collect (list :name (%frame-var-name frame i) + :value (%frame-var-value frame i) + :id 0)))) + +(defimplementation frame-var-value (frame var) + (%frame-var-value (nth-frame frame) var)) + +;;; Interpreter-Variablen-Environment has the shape +;;; NIL or #(v1 val1 ... vn valn NEXT-ENV). + +(defun %frame-count-vars (frame) + (cond ((sys::eval-frame-p frame) + (do ((venv (frame-venv frame) (next-venv venv)) + (count 0 (+ count (/ (1- (length venv)) 2)))) + ((not venv) count))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (length (%parse-stack-values frame))) + (t 0))) + +(defun %frame-var-name (frame i) + (cond ((sys::eval-frame-p frame) + (nth-value 0 (venv-ref (frame-venv frame) i))) + (t (format nil "~D" i)))) + +(defun %frame-var-value (frame i) + (cond ((sys::eval-frame-p frame) + (let ((name (venv-ref (frame-venv frame) i))) + (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name)) + (if c + (format-sldb-condition c) + v)))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (let ((str (nth i (%parse-stack-values frame)))) + (trim-whitespace (subseq str 2)))) + (t (break "Not implemented")))) + +(defun frame-venv (frame) + (let ((env (sys::eval-at frame '(sys::the-environment)))) + (svref env 0))) + +(defun next-venv (venv) (svref venv (1- (length venv)))) + +(defun venv-ref (env i) + "Reference the Ith binding in ENV. +Return two values: NAME and VALUE" + (let ((idx (* i 2))) + (if (< idx (1- (length env))) + (values (svref env idx) (svref env (1+ idx))) + (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) + +(defun %parse-stack-values (frame) + (labels ((next (fp) (sys::frame-down-1 fp 1)) + (parse (fp accu) + (let ((str (frame-to-string fp))) + (cond ((is-prefix-p "- " str) + (parse (next fp) (cons str accu))) + ((is-prefix-p "<1> " str) + ;;(when (eq (frame-type frame) 'compiled-fun) + ;; (pop accu)) + (dolist (str (cdr (split-frame-string str))) + (when (is-prefix-p "- " str) + (push str accu))) + (nreverse accu)) + (t (parse (next fp) accu)))))) + (parse (next frame) '()))) + +(defun is-prefix-p (pattern string) + (not (mismatch pattern string :end2 (min (length pattern) + (length string))))) + +(defimplementation frame-catch-tags (index) + (declare (ignore index)) + nil) + +(defimplementation return-from-frame (index form) + (sys::return-from-eval-frame (nth-frame index) form)) + +(defimplementation restart-frame (index) + (sys::redo-eval-frame (nth-frame index))) + +(defimplementation frame-source-location-for-emacs (index) + `(:error + ,(format nil "frame-source-location not implemented. (frame: ~A)" + (nth-frame index)))) + +;;;; Profiling + +(defimplementation profile (fname) + (eval `(mon:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + mon:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (mon:unmonitor)) + +(defimplementation profile-report () + (mon:report-monitoring)) + +(defimplementation profile-reset () + (mon:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (mon:monitor-all package)) + +;;;; Handle compiler conditions (find out location of error etc.) + +(defmacro compile-file-frobbing-notes ((&rest args) &body body) + "Pass ARGS to COMPILE-FILE, send the compiler notes to +*STANDARD-INPUT* and frob them in BODY." + `(let ((*error-output* (make-string-output-stream)) + (*compile-verbose* t)) + (multiple-value-prog1 + (compile-file ,@args) + (handler-case + (with-input-from-string + (*standard-input* (get-output-stream-string *error-output*)) + ,@body) + (sys::simple-end-of-file () nil))))) + +(defvar *orig-c-warn* (symbol-function 'system::c-warn)) +(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn)) +(defvar *orig-c-error* (symbol-function 'system::c-error)) +(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems)) + +(defmacro dynamic-flet (names-functions &body body) + "(dynamic-flet ((NAME FUNCTION) ...) BODY ...) +Execute BODY with NAME's function slot set to FUNCTION." + `(ext:letf* ,(loop for (name function) in names-functions + collect `((symbol-function ',name) ,function)) + ,@body)) + +(defvar *buffer-name* nil) +(defvar *buffer-offset*) + +(defun compiler-note-location () + "Return the current compiler location." + (let ((lineno1 sys::*compile-file-lineno1*) + (lineno2 sys::*compile-file-lineno2*) + (file sys::*compile-file-truename*)) + (cond ((and file lineno1 lineno2) + (make-location (list ':file (namestring file)) + (list ':line lineno1))) + (*buffer-name* + (make-location (list ':buffer *buffer-name*) + (list ':position *buffer-offset*))) + (t + (list :error "No error location available"))))) + +(defun signal-compiler-warning (cstring args severity orig-fn) + (signal (make-condition 'compiler-condition + :severity severity + :message (apply #'format nil cstring args) + :location (compiler-note-location))) + (apply orig-fn cstring args)) + +(defun c-warn (cstring &rest args) + (signal-compiler-warning cstring args :warning *orig-c-warn*)) + +(defun c-style-warn (cstring &rest args) + (dynamic-flet ((sys::c-warn *orig-c-warn*)) + (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*))) + +(defun c-error (cstring &rest args) + (signal-compiler-warning cstring args :error *orig-c-error*)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-notification-condition)) + (dynamic-flet ((system::c-warn #'c-warn) + (system::c-style-warn #'c-style-warn) + (system::c-error #'c-error)) + (funcall function)))) + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (signal (make-condition 'compiler-condition + :original-condition condition + :severity :warning + :message (princ-to-string condition) + :location (compiler-note-location)))) + +(defimplementation swank-compile-file (filename load-p external-format) + (with-compilation-hooks () + (with-compilation-unit () + (let ((fasl-file (compile-file filename + :external-format external-format))) + (when (and load-p fasl-file) + (load fasl-file)) + nil)))) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-offset* position)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string))))))) + +;;;; Portable XREF from the CMU AI repository. + +(setq pxref::*handle-package-forms* '(cl:in-package)) + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls pxref:list-callers) +(defxref who-references pxref:list-readers) +(defxref who-binds pxref:list-setters) +(defxref who-sets pxref:list-setters) +(defxref list-callers pxref:list-callers) +(defxref list-callees pxref:list-callees) + +(defun xref-results (symbols) + (let ((xrefs '())) + (dolist (symbol symbols) + (push (list symbol (fspec-location symbol)) xrefs)) + xrefs)) + +(when (find-package :swank-loader) + (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader)) + (lambda () + (let ((home (user-homedir-pathname))) + (and (ext:probe-directory home) + (probe-file (format nil "~A/.swank.lisp" + (namestring (truename home))))))))) + +;;; Don't set *debugger-hook* to nil on break. +(ext:without-package-lock () + (defun break (&optional (format-string "Break") &rest args) + (if (not sys::*use-clcs*) + (progn + (terpri *error-output*) + (apply #'format *error-output* + (concatenate 'string "*** - " format-string) + args) + (funcall ext:*break-driver* t)) + (let ((condition + (make-condition 'simple-condition + :format-control format-string + :format-arguments args)) + ;;(*debugger-hook* nil) + ;; Issue 91 + ) + (ext:with-restarts + ((continue + :report (lambda (stream) + (format stream (sys::text "Return from ~S loop") + 'break)) + ())) + (with-condition-restarts condition (list (find-restart 'continue)) + (invoke-debugger condition))))) + nil)) + +;;;; Inspecting + +(defclass clisp-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () (make-instance 'clisp-inspector)) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (declare (ignore inspector)) + (let* ((*print-array* nil) (*print-pretty* t) + (*print-circle* t) (*print-escape* t) + (*print-lines* custom:*inspect-print-lines*) + (*print-level* custom:*inspect-print-level*) + (*print-length* custom:*inspect-print-length*) + (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t)) + (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-"))) + (*package* tmp-pack) + (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack))) + (let ((inspection (sys::inspect-backend o))) + (values (format nil "~S~% ~A~{~%~A~}" o + (sys::insp-title inspection) + (sys::insp-blurb inspection)) + (loop with count = (sys::insp-num-slots inspection) + for i below count + append (multiple-value-bind (value name) + (funcall (sys::insp-nth-slot inspection) + i) + `((:value ,name) " = " (:value ,value) + (:newline)))))))) + +(defimplementation quit-lisp () + #+lisp=cl (ext:quit) + #-lisp=cl (lisp:quit)) + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +;;; Local Variables: +;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1) +;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1) +;;; End:
Added: branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,2255 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; License: Public Domain +;;; +;;;; Introduction +;;; +;;; This is the CMUCL implementation of the `swank-backend' package. + +(in-package :swank-backend) + +(import-swank-mop-symbols :pcl '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +;;;; "Hot fixes" +;;; +;;; Here are necessary bugfixes to the oldest supported version of +;;; CMUCL (currently 18e). Any fixes placed here should also be +;;; submitted to the `cmucl-imp' mailing list and confirmed as +;;; good. When a new release is made that includes the fixes we should +;;; promptly delete them from here. It is enough to be compatible with +;;; the latest release. + +(in-package :lisp) + +;;; `READ-SEQUENCE' with large sequences has problems in 18e. This new +;;; definition works better. + +#-cmu19 +(progn + (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp))) + (when s + (setf (symbol-value s) nil))) + + (defun read-into-simple-string (s stream start end) + (declare (type simple-string s)) + (declare (type stream stream)) + (declare (type index start end)) + (unless (subtypep (stream-element-type stream) 'character) + (error 'type-error + :datum (read-char stream nil #\Null) + :expected-type (stream-element-type stream) + :format-control "Trying to read characters from a binary stream.")) + ;; Let's go as low level as it seems reasonable. + (let* ((numbytes (- end start)) + (total-bytes 0)) + ;; read-n-bytes may return fewer bytes than requested, so we need + ;; to keep trying. + (loop while (plusp numbytes) do + (let ((bytes-read (system:read-n-bytes stream s start numbytes nil))) + (when (zerop bytes-read) + (return-from read-into-simple-string total-bytes)) + (incf total-bytes bytes-read) + (incf start bytes-read) + (decf numbytes bytes-read))) + total-bytes)) + + (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp))) + (when s + (setf (symbol-value s) t))) + + ) + +(in-package :swank-backend) + + +;;;; TCP server +;;; +;;; In CMUCL we support all communication styles. By default we use +;;; `:SIGIO' because it is the most responsive, but it's somewhat +;;; dangerous: CMUCL is not in general "signal safe", and you don't +;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and +;;; `:SPAWN' are reasonable alternatives. + +(defimplementation preferred-communication-style () + :sigio) + +#-(or darwin mips) +(defimplementation create-socket (host port) + (let* ((addr (resolve-hostname host)) + (addr (if (not (find-symbol "SOCKET-ERROR" :ext)) + (ext:htonl addr) + addr))) + (ext:create-inet-listener port :stream :reuse-address t :host addr))) + +;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix. +#+(or darwin mips) +(defimplementation create-socket (host port) + (declare (ignore host)) + (ext:create-inet-listener port :stream :reuse-address t)) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (let ((fd (socket-fd socket))) + (sys:invalidate-descriptor fd) + (ext:close-socket fd))) + +(defimplementation accept-connection (socket &key + external-format buffering timeout) + (declare (ignore timeout external-format)) + (let ((buffering (or buffering :full))) + (make-socket-io-stream (ext:accept-tcp-connection socket) buffering))) + +;;;;; Sockets + +(defun socket-fd (socket) + "Return the filedescriptor for the socket represented by SOCKET." + (etypecase socket + (fixnum socket) + (sys:fd-stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of HOSTNAME as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(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 + :buffering buffering)) + +;;;;; Signal-driven I/O + +(defvar *sigio-handlers* '() + "List of (key . function) pairs. +All functions are called on SIGIO, and the key is used for removing +specific functions.") + +(defun set-sigio-handler () + (sys:enable-interrupt :sigio (lambda (signal code scp) + (sigio-handler signal code scp)))) + +(defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (mapc #'funcall (mapcar #'cdr *sigio-handlers*))) + +(defun fcntl (fd command arg) + "fcntl(2) - manipulate a file descriptor." + (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg) + (unless ok (error "fcntl: ~A" (unix:get-unix-error-msg error))))) + +(defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (fcntl fd unix:f-setown (unix:unix-getpid)) + (fcntl fd unix:f-setfl unix:fasync) + (push (cons fd fn) *sigio-handlers*))) + +(defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car)) + (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))))) + +(defimplementation remove-fd-handlers (socket) + (sys:invalidate-descriptor (socket-fd socket))) + + +;;;; Stream handling +;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004) + +(defimplementation make-fn-streams (input-fn output-fn) + (let* ((output (make-slime-output-stream output-fn)) + (input (make-slime-input-stream input-fn output))) + (values input output))) + +(defstruct (slime-output-stream + (:include lisp::lisp-stream + (lisp::misc #'sos/misc) + (lisp::out #'sos/out) + (lisp::sout #'sos/sout)) + (:conc-name sos.) + (:print-function %print-slime-output-stream) + (:constructor make-slime-output-stream (output-fn))) + (output-fn nil :type function) + (buffer (make-string 8000) :type string) + (index 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) + (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) + (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 + (: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) + (:element-type 'base-char) + (:get-command nil) + (: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) + (lisp::misc #'sis/misc)) + (:conc-name sis.) + (:print-function %print-slime-output-stream) + (:constructor make-slime-input-stream (input-fn sos))) + (input-fn nil :type function) + ;; We know our sibling output stream, so that we can force it before + ;; requesting input. + (sos nil :type slime-output-stream) + (buffer "" :type string) + (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)) + (let ((string (funcall (sis.input-fn stream)))) + (cond ((zerop (length string)) + (return-from sis/in + (if eof-errorp + (error (make-condition 'end-of-file :stream stream)) + eof-value))) + (t + (setf buffer string) + (setf (sis.buffer stream) buffer) + (setf index 0))))) + (prog1 (aref buffer index) + (setf (sis.index stream) (1+ index))))) + +(defun sis/misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (ecase operation + (:file-position nil) + (:file-length nil) + (:unread (setf (aref (sis.buffer stream) + (decf (sis.index stream))) + arg1)) + (:clear-input + (setf (sis.index stream) 0 + (sis.buffer stream) "")) + (:listen (< (sis.index stream) (length (sis.buffer stream)))) + (:charpos nil) + (:line-length nil) + (:get-command nil) + (:element-type 'base-char) + (:close nil) + (:interactive-p t))) + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. +NIL if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (filename load-p external-format) + (declare (ignore external-format)) + (clear-xref-info filename) + (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) + (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)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string)) + (with-input-from-string (stream string) + (ext:compile-from-stream + stream + :source-info `(:emacs-buffer ,buffer + :emacs-buffer-offset ,position + :emacs-buffer-string ,string)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `SWANK:COMPILER-CONDITION's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal (make-condition + 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :short-message (brief-compiler-message-for-emacs condition) + :message (long-compiler-message-for-emacs condition context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context))))) + +(defun severity-for-emacs (condition) + "Return the severity of CONDITION." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (princ-to-string condition)) + +(defun long-compiler-message-for-emacs (condition error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A" + enclosing source condition))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :position (+ *buffer-start-position* pos)))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. +Return a `location' record, or (:error REASON) on failure." + (if (null context) + (note-error-location) + (let ((file (c::compiler-error-context-file-name context)) + (source (c::compiler-error-context-original-source context)) + (path + (reverse (c::compiler-error-context-original-source-path context)))) + (or (locate-compiler-note file source path) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (list :error "No error location available.")) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (let ((position (+ *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + (make-location (list :buffer *buffer-name*) + (list :position position)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position + (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + +;;;; XREF +;;; +;;; Cross-reference support is based on the standard CMUCL `XREF' +;;; package. This package has some caveats: XREF information is +;;; recorded during compilation and not preserved in fasl files, and +;;; XREF recording is disabled by default. Redefining functions can +;;; also cause duplicate references to accumulate, but +;;; `swank-compile-file' will automatically clear out any old records +;;; from the same filename. +;;; +;;; To enable XREF recording, set `c:*record-xref-info*' to true. To +;;; clear out the XREF database call `xref:init-xref-database'. + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls xref:who-calls) +(defxref who-references xref:who-references) +(defxref who-binds xref:who-binds) +(defxref who-sets xref:who-sets) + +;;; More types of XREF information were added since 18e: +;;; +#+cmu19 +(progn + (defxref who-macroexpands xref:who-macroexpands) + ;; XXX + (defimplementation who-specializes (symbol) + (let* ((methods (xref::who-specializes (find-class symbol))) + (locations (mapcar #'method-location methods))) + (mapcar #'list methods locations)))) + +(defun xref-results (contexts) + (mapcar (lambda (xref) + (list (xref:xref-context-name xref) + (resolve-xref-location xref))) + contexts)) + +(defun resolve-xref-location (xref) + (let ((name (xref:xref-context-name xref)) + (file (xref:xref-context-file xref)) + (source-path (xref:xref-context-source-path xref))) + (cond ((and file source-path) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (unix-truename file)) + (list :position (1+ position))))) + (file + (make-location (list :file (unix-truename file)) + (list :function-name (string name)))) + (t + `(:error ,(format nil "Unknown source location: ~S ~S ~S " + name file source-path)))))) + +(defun clear-xref-info (namestring) + "Clear XREF notes pertaining to NAMESTRING. +This is a workaround for a CMUCL bug: XREF records are cumulative." + (when c:*record-xref-info* + (let ((filename (truename namestring))) + (dolist (db (list xref::*who-calls* + #+cmu19 xref::*who-is-called* + #+cmu19 xref::*who-macroexpands* + xref::*who-references* + xref::*who-binds* + xref::*who-sets*)) + (maphash (lambda (target contexts) + ;; XXX update during traversal? + (setf (gethash target db) + (delete filename contexts + :key #'xref:xref-context-file + :test #'equalp))) + db))))) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(declaim (inline map-code-constants)) +(defun map-code-constants (code fn) + "Call FN for each constant in CODE's constant pool." + (check-type code kernel:code-component) + (loop for i from vm:code-constants-offset below (kernel:get-header-data code) + do (funcall fn (kernel:code-header-ref code i)))) + +(defun function-callees (function) + "Return FUNCTION's callees as a list of functions." + (let ((callees '())) + (map-code-constants + (vm::find-code-object function) + (lambda (obj) + (when (kernel:fdefn-p obj) + (push (kernel:fdefn-function obj) callees)))) + callees)) + +(declaim (ext:maybe-inline map-allocated-code-components)) +(defun map-allocated-code-components (spaces fn) + "Call FN for each allocated code component in one of SPACES. FN +receives the object as argument. SPACES should be a list of the +symbols :dynamic, :static, or :read-only." + (dolist (space spaces) + (declare (inline vm::map-allocated-objects) + (optimize (ext:inhibit-warnings 3))) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum size) (ignore size)) + (when (= vm:code-header-type header) + (funcall fn obj))) + space))) + +(declaim (ext:maybe-inline map-caller-code-components)) +(defun map-caller-code-components (function spaces fn) + "Call FN for each code component with a fdefn for FUNCTION in its +constant pool." + (let ((function (coerce function 'function))) + (declare (inline map-allocated-code-components)) + (map-allocated-code-components + spaces + (lambda (obj) + (map-code-constants + obj + (lambda (constant) + (when (and (kernel:fdefn-p constant) + (eq (kernel:fdefn-function constant) + function)) + (funcall fn obj)))))))) + +(defun function-callers (function &optional (spaces '(:read-only :static + :dynamic))) + "Return FUNCTION's callers. The result is a list of code-objects." + (let ((referrers '())) + (declare (inline map-caller-code-components)) + ;;(ext:gc :full t) + (map-caller-code-components function spaces + (lambda (code) (push code referrers))) + referrers)) + +(defun debug-info-definitions (debug-info) + "Return the defintions for a debug-info. This should only be used +for code-object without entry points, i.e., byte compiled +code (are theree others?)" + ;; This mess has only been tested with #'ext::skip-whitespace, a + ;; byte-compiled caller of #'read-char . + (check-type debug-info (and (not c::compiled-debug-info) c::debug-info)) + (let ((name (c::debug-info-name debug-info)) + (source (c::debug-info-source debug-info))) + (destructuring-bind (first) source + (ecase (c::debug-source-from first) + (:file + (list (list name + (make-location + (list :file (unix-truename (c::debug-source-name first))) + (list :function-name (string name)))))))))) + +(defun code-component-entry-points (code) + "Return a list ((NAME LOCATION) ...) of function definitons for +the code omponent CODE." + (let ((names '())) + (do ((f (kernel:%code-entry-points code) (kernel::%function-next f))) + ((not f)) + (let ((name (kernel:%function-name f))) + (when (ext:valid-function-name-p name) + (push (list name (function-location f)) names)))) + names)) + +(defimplementation list-callers (symbol) + "Return a list ((NAME LOCATION) ...) of callers." + (let ((components (function-callers symbol)) + (xrefs '())) + (dolist (code components) + (let* ((entry (kernel:%code-entry-points code)) + (defs (if entry + (code-component-entry-points code) + ;; byte compiled stuff + (debug-info-definitions + (kernel:%code-debug-info code))))) + (setq xrefs (nconc defs xrefs)))) + xrefs)) + +(defimplementation list-callees (symbol) + (let ((fns (function-callees symbol))) + (mapcar (lambda (fn) + (list (kernel:%function-name fn) + (function-location fn))) + fns))) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the CMUCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `swank-source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. +This is useful when debugging the definition-finding code.") + +(defvar *source-snippet-size* 256 + "Maximum number of characters in a snippet of source code. +Snippets at the beginning of definitions are used to tell Emacs what +the definitions looks like, so that it can accurately find them by +text search.") + +(defmacro safe-definition-finding (&body body) + "Execute BODY and return the source-location it returns. +If an error occurs and `*debug-definition-finding*' is false, then +return an error pseudo-location. + +The second return value is NIL if no error occurs, otherwise it is the +condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values `(:error ,(trim-whitespace (princ-to-string c))) + c)))))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for CODE-LOCATION." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for CODE-LOCATION in FILENAME." + (let* ((code-date (di:debug-source-created debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a CODE-LOCATION from a stream. +This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :position (+ (getf info :emacs-buffer-offset) position)) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for DEBUG-INFO. +Function-name source-locations are a fallback for when precise +positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location? +This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream) + "Return the byte offset of CODE-LOCATION in STREAM. Extract the +toplevel-form-number and form-number from CODE-LOCATION and use that +to find the position of the corresponding form. + +Finish with STREAM positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (di:code-location-top-level-form-offset location)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in STREAM. +TLF-NUMBER is the top-level-form number. +FORM-NUMBER is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of CODE-LOCATION in STRING. +See CODE-LOCATION-STREAM-POSITION." + (with-input-from-string (s string) + (code-location-stream-position code-location s))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name))) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; CMUCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the CMUCL manual for more details. + +(defun function-definitions (name) + "Return definitions for NAME in the "function namespace", i.e., +regular functions, generic functions, methods and macros. +NAME can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (special? (and (symbolp name) (special-operator-p name))) + (function? (and (ext:valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (special? + (list `((:special-operator ,name) + (:error ,(format nil "Special operator: ~S" name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (generic-function-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for FUNCTION." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + + +(defun byte-function-location (fn) + "Return the location of the byte-compiled function FN." + (etypecase fn + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((component (c::byte-function-component fn)) + (debug-info (kernel:%code-debug-info component))) + (debug-info-function-name-location debug-info))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fn))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is FUNCTION a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that FUNCTION belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + ;; Find the location in a constructor. + (function-location (struct-constructor dd))) + +(defun struct-constructor (dd) + "Return a constructor function from a defstruct definition. +Signal an error if no constructor can be found." + (let ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (when (or (null constructor) + (and (consp constructor) (null (car constructor)))) + (error "Cannot find structure's constructor: ~S" + (kernel::dd-name dd))) + (coerce (if (consp constructor) (first constructor) constructor) + 'function))) + +;;;;;; Generic functions and methods + +(defun generic-function-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (pcl::generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (pcl::generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable "definition specifier" for METHOD." + (let* ((gf (pcl:method-generic-function method)) + (name (pcl:generic-function-name gf)) + (specializers (pcl:method-specializers method)) + (qualifiers (pcl:method-qualifiers method))) + `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers)))) + +;; XXX maybe special case setters/getters +(defun method-location (method) + (function-location (or (pcl::method-fast-function method) + (pcl:method-function method)))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (kernel::find-class name nil))) + (etypecase class + (null '()) + (kernel::structure-class + (list (list `(defstruct ,name) (dd-location (find-dd name))))) + #+(or) + (conditions::condition-class + (list (list `(define-condition ,name) + (condition-class-location class)))) + (kernel::standard-class + (list (list `(defclass ,name) + (class-location (find-class name))))) + ((or kernel::built-in-class + conditions::condition-class + kernel:funcallable-structure-class) + (list (list `(kernel::define-type-class ,name) + `(:error + ,(format nil "No source info for ~A" name))))))))) + +(defun class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (pcl:class-name class))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((slots (conditions::condition-class-slots class)) + (name (conditions::condition-class-name class))) + (cond ((null slots) + `(:error ,(format nil "No location info for condition: ~A" name))) + (t + ;; Find the class via one of its slot-reader methods. + (let* ((slot (first slots)) + (gf (fdefinition + (first (conditions::condition-slot-readers slot))))) + (method-location + (first + (pcl:compute-applicable-methods-using-classes + gf (list (find-class name)))))))))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun source-location-form-numbers (location) + (c::decode-form-numbers (c::form-numbers-form-numbers location))) + +(defun source-location-tlf-number (location) + (nth-value 0 (source-location-form-numbers location))) + +(defun source-location-form-number (location) + (nth-value 1 (source-location-form-numbers location))) + +(defun resolve-file-source-location (location) + (let ((filename (c::file-source-location-pathname location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + (with-open-file (s filename) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:file ,(unix-truename filename)) + `(:position ,(1+ pos))))))) + +(defun resolve-stream-source-location (location) + (let ((info (c::stream-source-location-user-info location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + ;; XXX duplication in frame-source-location + (assert (info-from-emacs-buffer-p info)) + (destructuring-bind (&key emacs-buffer emacs-buffer-string + emacs-buffer-offset) info + (with-input-from-string (s emacs-buffer-string) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:buffer ,emacs-buffer) + `(:position ,(+ emacs-buffer-offset pos)))))))) + +;; XXX predicates for 18e backward compatibilty. Remove them when +;; we're 19a only. +(defun file-source-location-p (object) + (when (fboundp 'c::file-source-location-p) + (c::file-source-location-p object))) + +(defun stream-source-location-p (object) + (when (fboundp 'c::stream-source-location-p) + (c::stream-source-location-p object))) + +(defun source-location-p (object) + (or (file-source-location-p object) + (stream-source-location-p object))) + +(defun resolve-source-location (location) + (etypecase location + ((satisfies file-source-location-p) + (resolve-file-source-location location)) + ((satisfies stream-source-location-p) + (resolve-stream-source-location location)))) + +(defun definition-source-location (object name) + (let ((source (pcl::definition-source object))) + (etypecase source + (null + `(:error ,(format nil "No source info for: ~A" object))) + ((satisfies source-location-p) + (resolve-source-location source)) + (pathname + (make-name-in-file-location source name)) + (cons + (destructuring-bind ((dg name) pathname) source + (declare (ignore dg)) + (etypecase pathname + (pathname (make-name-in-file-location pathname (string name))) + (null `(:error ,(format nil "Cannot resolve: ~S" source))))))))) + +(defun setf-definitions (name) + (let ((function (or (ext:info :setf :inverse 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))))))) + + +(defun variable-location (symbol) + (multiple-value-bind (location foundp) + ;; XXX for 18e compatibilty. rewrite this when we drop 18e + ;; support. + (ignore-errors (eval `(ext:info :source-location :defvar ',symbol))) + (if (and foundp location) + (resolve-source-location location) + `(:error ,(format nil "No source info for variable ~S" symbol))))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(c::vop ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unkown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (etypecase fun + (function (function-arglist fun)) + (symbol (function-arglist (or (macro-function fun) + (symbol-function fun)))))) + +(defun function-arglist (fun) + (let ((arglist + (cond ((eval:interpreted-function-p fun) + (eval:interpreted-function-arglist fun)) + ((pcl::generic-function-p fun) + (pcl:generic-function-lambda-list fun)) + ((c::byte-function-or-closure-p fun) + (byte-code-function-arglist fun)) + ((kernel:%function-arglist (kernel:%function-self fun)) + (handler-case (read-arglist fun) + (error () :not-available))) + ;; this should work both for compiled-debug-function + ;; and for interpreted-debug-function + (t + (handler-case (debug-function-arglist + (di::function-debug-function fun)) + (di:unhandled-condition () :not-available)))))) + (check-type arglist (or list (member :not-available))) + arglist)) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((pcl::generic-function-p function) + (pcl::generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + +;;; A simple case: the arglist is available as a string that we can +;;; `read'. + +(defun read-arglist (fn) + "Parse the arglist-string of the function object FN." + (let ((string (kernel:%function-arglist + (kernel:%function-self fn))) + (package (find-package + (c::compiled-debug-info-package + (kernel:%code-debug-info + (vm::find-code-object fn)))))) + (with-standard-io-syntax + (let ((*package* (or package *package*))) + (read-from-string string))))) + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. +A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + +;;; Deriving arglists for byte-compiled functions: +;;; +(defun byte-code-function-arglist (fn) + ;; There doesn't seem to be much arglist information around for + ;; byte-code functions. Use the arg-count and return something like + ;; (arg0 arg1 ...) + (etypecase fn + (c::simple-byte-function + (loop for i from 0 below (c::simple-byte-function-num-args fn) + collect (make-arg-symbol i))) + (c::hairy-byte-function + (hairy-byte-function-arglist fn)) + (c::byte-closure + (byte-code-function-arglist (c::byte-closure-function fn))))) + +(defun make-arg-symbol (i) + (make-symbol (format nil "~A~D" (string 'arg) i))) + +;;; A "hairy" byte-function is one that takes a variable number of +;;; arguments. `hairy-byte-function' is a type from the bytecode +;;; interpreter. +;;; +(defun hairy-byte-function-arglist (fn) + (let ((counter -1)) + (flet ((next-arg () (make-arg-symbol (incf counter)))) + (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p + keywords-p keywords) fn + (let ((arglist '()) + (optional (- max-args min-args))) + ;; XXX isn't there a better way to write this? + ;; (Looks fine to me. -luke) + (dotimes (i min-args) + (push (next-arg) arglist)) + (when (plusp optional) + (push '&optional arglist) + (dotimes (i optional) + (push (next-arg) arglist))) + (when rest-arg-p + (push '&rest arglist) + (push (next-arg) arglist)) + (when keywords-p + (push '&key arglist) + (loop for (key _ __) in keywords + do (push key arglist)) + (when (eq keywords-p :allow-others) + (push '&allow-other-keys arglist))) + (nreverse arglist)))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form) + (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 + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation call-without-interrupts (fn) + (sys:without-interrupts (funcall fn))) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + "cmucl") + +(defimplementation quit-lisp () + (ext::quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; swank-source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (unix:unix-sigsetmask 0) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error (make-condition + 'sldb-condition + :original-condition condition))))) + (unwind-protect + (progn + #+(or)(sys:scrub-control-stack) + (funcall debugger-loop-fn)) + #+(or)(sys:scrub-control-stack) + )))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f + collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location-for-emacs (index) + (code-location-source-location (di:frame-code-location (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (di::debug-function-debug-variables (di:frame-debug-function frame))) + +(defun debug-var-value (var frame location) + (let ((validity (di:debug-variable-validity var location))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (di:frame-code-location frame)) + (vars (frame-debug-vars frame))) + (loop for v across vars collect + (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame loc))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame (di:frame-code-location frame)))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (string 'find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of CMUCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +;; XXX don't break old versions without fwrappers. Remove this one day. +#+#.(cl:if (cl:find-package :fwrappers) '(and) '(or)) +(progn + (fwrappers:define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext) + (let ((*breakpoint-sigcontext* sigcontext) + (*breakpoint-pc* offset)) + (fwrappers:call-next-function))) + (fwrappers:set-fwrappers 'di::handle-breakpoint '()) + (fwrappers:fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext)) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:sigcontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:sigcontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; CMUCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<<known-return convention not supported>>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in +;; newer versions of CMUCL (after ~March 2005). +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di))) + (cond (sym (funcall sym sigcontext)) + (t (di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +(defimplementation condition-extras (condition) + (typecase condition + (breakpoint + ;; pop up the source buffer + `((:show-frame-source 0))) + (t '()))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + ((or di::bogus-debug-function di::interpreted-debug-function) + -1))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +CSP = ~X +CFP = ~X +IP = ~X +OCFP = ~X +LRA = ~X~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + + +(defimplementation disassemble-frame (frame-number) + "Return a string with the disassembly of frames code." + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (format t "~%[Disassembling bogus frames not implemented]"))))) + + +;;;; Inspecting + +(defclass cmucl-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'cmucl-inspector)) + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:instance-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp "-TYPE" (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list "-TYPE" "VM") + (apropos-list "-TYPE" "BIGNUM")))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (cond ((di::indirect-value-cell-p o) + (values (format nil "~A is a value cell." o) + `("Value: " (:value ,(c:value-cell-ref o))))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (cmucl-inspect o)))) + +(defun cmucl-inspect (o) + (destructuring-bind (text labeledp . parts) (inspect::describe-parts o) + (values (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) + (declare (ignore inspector)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (values (format nil "~A is a function." o) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s)))))) + ((= header vm:closure-header-type) + (values (format nil "~A is a closure" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (1- (kernel:get-closure-length o)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (cmucl-inspect o)) + (t + (call-next-method))))) + +(defmethod inspect-for-emacs ((o kernel:funcallable-instance) + (i backend-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) (_ backend-inspector)) + (declare (ignore _)) + (values (format nil "~A is a code data-block." o) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((kernel:%code-debug-info o) + (disassem:disassemble-code-component o :stream s)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift) + :stream s)))))))) + +(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector)) + (declare (ignore inspector)) + (values (format nil "~A is a fdenf object." o) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) + +(defmethod inspect-for-emacs ((o array) (inspector backend-inspector)) + inspector + (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 simple-vector) (inspector backend-inspector)) + inspector + (values (format nil "~A is a simple-vector." o) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (loop for i below (length o) + append (label-value-line i (aref o i)))))) + +(defun inspect-alien-record (alien) + (values + (format nil "~A is an alien value." alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (label-value-line slot (alien:slot alien slot))))))))) + +(defun inspect-alien-pointer (alien) + (values + (format nil "~A is an alien value." alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien)))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (cmucl-inspect alien)))) + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + #-cmu18e :methods #-cmu18e methods)) + + +;;;; Multiprocessing + +#+mp +(progn + (defimplementation initialize-multiprocessing (continuation) + (mp::init-multi-processing) + (mp:make-process continuation :name "swank") + ;; Threads magic: this never returns! But top-level becomes + ;; available again. + (unless mp::*idle-process* + (mp::startup-idle-and-top-level-loops))) + + (defimplementation spawn (fn &key name) + (mp:make-process fn :name (or name "Anonymous"))) + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*)))) + + (defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (mp:process-whostate thread)) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (copy-list mp:*all-processes*)) + + (defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + + (defimplementation kill-thread (thread) + (mp:destroy-process thread)) + + (defvar *mailbox-lock* (mp:make-lock "mailbox lock")) + + (defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock "process mailbox")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock-held (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (mp:with-lock-held (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + + (defimplementation receive () + (let* ((mbox (mailbox mp:*current-process*)) + (mutex (mailbox.mutex mbox))) + (mp:process-wait "receive" #'mailbox.queue mbox) + (mp:with-lock-held (mutex) + (pop (mailbox.queue mbox))))) + + ) ;; #+mp + + + +;;;; GC hooks +;;; +;;; Display GC messages in the echo area to avoid cluttering the +;;; normal output. +;;; + +;; this should probably not be here, but where else? +(defun background-message (message) + (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." + (let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb)))) + (multiple-value-bind (power name) + (loop for ((p1 n1) (p2 n2)) on names + while n2 do + (when (<= (expt 2 p1) nbytes (1- (expt 2 p2))) + (return (values p1 n1)))) + (cond (name + (format stream "~,1F ~A" (/ nbytes (expt 2 power)) name)) + (t + (format stream "~:D bytes" nbytes)))))) + +(defconstant gc-generations 6) + +#+gencgc +(defun generation-stats () + "Return a string describing the size distribution among the generations." + (let* ((alloc (loop for i below gc-generations + collect (lisp::gencgc-stats i))) + (sum (coerce (reduce #'+ alloc) 'float))) + (format nil "~{~3F~^/~}" + (mapcar (lambda (size) (/ size sum)) + alloc)))) + +(defvar *gc-start-time* 0) + +(defun pre-gc-hook (bytes-in-use) + (setq *gc-start-time* (get-internal-real-time)) + (let ((msg (format nil "[Commencing GC with ~A in use.]" + (print-bytes bytes-in-use)))) + (background-message msg))) + +(defun post-gc-hook (bytes-retained bytes-freed trigger) + (declare (ignore trigger)) + (let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*) + internal-time-units-per-second)) + (msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]" + (print-bytes bytes-freed) + (print-bytes bytes-retained) + #+gencgc(generation-stats) + #-gencgc"" + seconds))) + (background-message msg))) + +(defun install-gc-hooks () + (setq ext:*gc-notify-before* #'pre-gc-hook) + (setq ext:*gc-notify-after* #'post-gc-hook)) + +(defun remove-gc-hooks () + (setq ext:*gc-notify-before* #'lisp::default-gc-notify-before) + (setq ext:*gc-notify-after* #'lisp::default-gc-notify-after)) + +(defvar *install-gc-hooks* t + "If non-nil install GC hooks") + +(defimplementation emacs-connected () + (when *install-gc-hooks* + (install-gc-hooks))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;;In CMUCL, we have: +;; (trace <name>) +;; (trace (method <name> <qualifier>? (<specializer>+))) +;; (trace :methods t '<name>) ;;to trace all methods of the gf <name> +;; <name> can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + (cond ((fboundp `(method ,@(cdr spec))) + (toggle-trace-aux `(method ,(cdr spec)))) + ;; Man, is this ugly + ((fboundp `(pcl::fast-method ,@(cdr spec))) + (toggle-trace-aux `(pcl::fast-method ,@(cdr spec)))) + (t + (error 'undefined-function :name (cdr spec))))) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))) + ;; doesn't work properly + ;; ((:labels :flet) (toggle-trace-aux (process-fspec spec))) + )) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ((:labels) `(labels ,(third fspec) ,(process-fspec (second fspec)))) + ((:flet) `(flet ,(third fspec) ,(process-fspec (second fspec)))))) + (t + fspec))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) + +;; Local Variables: +;; pbook-heading-regexp: "^;;;\(;+\)" +;; pbook-commentary-regexp: "^;;;\($\|[^;]\)" +;; End:
Added: branches/trunk-reorg/thirdparty/slime/swank-corman.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-corman.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-corman.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,580 @@ +;;; +;;; swank-corman.lisp --- Corman Lisp specific code for SLIME. +;;; +;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org) +;;; +;;; License +;;; ======= +;;; This software is provided 'as-is', without any express or implied +;;; warranty. In no event will the author be held liable for any damages +;;; arising from the use of this software. +;;; +;;; Permission is granted to anyone to use this software for any purpose, +;;; including commercial applications, and to alter it and redistribute +;;; it freely, subject to the following restrictions: +;;; +;;; 1. The origin of this software must not be misrepresented; you must +;;; not claim that you wrote the original software. If you use this +;;; software in a product, an acknowledgment in the product documentation +;;; would be appreciated but is not required. +;;; +;;; 2. Altered source versions must be plainly marked as such, and must +;;; not be misrepresented as being the original software. +;;; +;;; 3. This notice may not be removed or altered from any source +;;; distribution. +;;; +;;; Notes +;;; ===== +;;; You will need CCL 2.51, and you will *definitely* need to patch +;;; CCL with the patches at +;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME +;;; will blow up in your face. You should also follow the +;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime. +;;; +;;; The only communication style currently supported is NIL. +;;; +;;; Starting CCL inside emacs (with M-x slime) seems to work for me +;;; with Corman Lisp 2.51, but I have seen random failures with 2.5 +;;; (sometimes it works, other times it hangs on start or hangs when +;;; initializing WinSock) - starting CCL externally and using M-x +;;; slime-connect always works fine. +;;; +;;; Sometimes CCL gets confused and starts giving you random memory +;;; access violation errors on startup; if this happens, try redumping +;;; your image. +;;; +;;; What works +;;; ========== +;;; * Basic editing and evaluation +;;; * Arglist display +;;; * Compilation +;;; * Loading files +;;; * apropos/describe +;;; * Debugger +;;; * Inspector +;;; +;;; TODO +;;; ==== +;;; * More debugger functionality (missing bits: restart-frame, +;;; return-from-frame, disassemble-frame, activate-stepping, +;;; toggle-trace) +;;; * XREF +;;; * Profiling +;;; * More sophisticated communication styles than NIL +;;; + +(in-package :swank-backend) + +;;; Pull in various needed bits +(require :composite-streams) +(require :sockets) +(require :winbase) +(require :lp) + +(use-package :gs) + +;; MOP stuff + +(defclass swank-mop:standard-slot-definition () + () + (:documentation "Dummy class created so that swank.lisp will compile and load.")) + +(defun named-by-gensym-p (c) + (null (symbol-package (class-name c)))) + +(deftype swank-mop:eql-specializer () + '(satisfies named-by-gensym-p)) + +(defun swank-mop:eql-specializer-object (specializer) + (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*) + (loop (multiple-value-bind (more key value) + (next-entry) + (unless more (return nil)) + (when (eq specializer value) + (return key)))))) + +(defun swank-mop:class-finalized-p (class) + (declare (ignore class)) + t) + +(defun swank-mop:class-prototype (class) + (make-instance class)) + +(defun swank-mop:specializer-direct-methods (obj) + (declare (ignore obj)) + nil) + +(defun swank-mop:generic-function-argument-precedence-order (gf) + (generic-function-lambda-list gf)) + +(defun swank-mop:generic-function-method-combination (gf) + (declare (ignore gf)) + :standard) + +(defun swank-mop:generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(defun swank-mop:slot-definition-documentation (slot) + (declare (ignore slot)) + (getf slot :documentation nil)) + +(defun swank-mop:slot-definition-type (slot) + (declare (ignore slot)) + t) + +(import-swank-mop-symbols :cl '(;; classes + :standard-slot-definition + :eql-specializer + :eql-specializer-object + ;; standard class readers + :class-default-initargs + :class-direct-default-initargs + :class-finalized-p + :class-prototype + :specializer-direct-methods + ;; gf readers + :generic-function-argument-precedence-order + :generic-function-declarations + :generic-function-method-combination + ;; method readers + ;; slot readers + :slot-definition-documentation + :slot-definition-type)) + +;;;; swank implementations + +;;; Debugger + +(defvar *stack-trace* nil) +(defvar *frame-trace* nil) + +(defstruct frame + name function address debug-info variables) + +(defimplementation call-with-debugging-environment (fn) + (let* ((real-stack-trace (cl::stack-trace)) + (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace + :key #'car))) + (*frame-trace* + (let* ((db::*debug-level* (1+ db::*debug-level*)) + (db::*debug-frame-pointer* (db::stash-ebp + (ct:create-foreign-ptr))) + (db::*debug-max-level* (length real-stack-trace)) + (db::*debug-min-level* 1)) + (cdr (member #'cl:invoke-debugger + (cons + (make-frame :function nil) + (loop for i from db::*debug-min-level* + upto db::*debug-max-level* + until (eq (db::get-frame-function i) cl::*top-level*) + collect + (make-frame :function (db::get-frame-function i) + :address (db::get-frame-address i)))) + :key #'frame-function))))) + (funcall fn))) + +(defimplementation compute-backtrace (start end) + (subseq *stack-trace* start (min end (length *stack-trace*)))) + +(defimplementation print-frame (frame stream) + (format stream "~S" frame)) + +(defun get-frame-debug-info (frame) + (or (frame-debug-info frame) + (setf (frame-debug-info frame) + (db::prepare-frame-debug-info (frame-function frame) + (frame-address frame))))) + +(defimplementation frame-locals (frame-number) + (let* ((frame (elt *frame-trace* frame-number)) + (info (get-frame-debug-info frame))) + (let ((var-list + (loop for i from 4 below (length info) by 2 + collect `(list :name ',(svref info i) :id 0 + :value (db::debug-filter ,(svref info i)))))) + (let ((vars (eval-in-frame `(list ,@var-list) frame-number))) + (setf (frame-variables frame) vars))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (elt *frame-trace* frame-number))) + (let ((cl::*compiler-environment* (get-frame-debug-info frame))) + (eval form)))) + +(defimplementation frame-catch-tags (index) + (declare (ignore index)) + nil) + +(defimplementation frame-var-value (frame-number var) + (let ((vars (frame-variables (elt *frame-trace* frame-number)))) + (when vars + (second (elt vars var))))) + +(defimplementation frame-source-location-for-emacs (frame-number) + (fspec-location (frame-function (elt *frame-trace* frame-number)))) + +(defun break (&optional (format-control "Break") &rest format-arguments) + (with-simple-restart (continue "Return from BREAK.") + (let ();(*debugger-hook* nil)) + (let ((condition + (make-condition 'simple-condition + :format-control format-control + :format-arguments format-arguments))) + ;;(format *debug-io* ";;; User break: ~A~%" condition) + (invoke-debugger condition)))) + nil) + +;;; Socket communication + +(defimplementation create-socket (host port) + (sockets:start-sockets) + (sockets:make-server-socket :host host :port port)) + +(defimplementation local-port (socket) + (sockets:socket-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout external-format)) + (sockets:make-socket-stream (sockets:accept-socket socket))) + +;;; Misc + +(defimplementation preferred-communication-style () + nil) + +(defimplementation getpid () + ccl:*current-process-id*) + +(defimplementation lisp-implementation-type-name () + "cormanlisp") + +(defimplementation quit-lisp () + (sockets:stop-sockets) + (win32:exitprocess 0)) + +(defimplementation set-default-directory (directory) + (setf (ccl:current-directory) directory) + (directory-namestring (setf *default-pathname-defaults* + (truename (merge-pathnames directory))))) + +(defimplementation default-directory () + (directory-namestring (ccl:current-directory))) + +(defimplementation macroexpand-all (form) + (ccl:macroexpand-all form)) + +;;; Documentation + +(defun fspec-location (fspec) + (when (symbolp fspec) + (setq fspec (symbol-function fspec))) + (let ((file (ccl::function-source-file fspec))) + (if file + (handler-case + (let ((truename (truename + (merge-pathnames file + ccl:*cormanlisp-directory*)))) + (make-location (list :file (namestring truename)) + (if (ccl::function-source-line fspec) + (list :line + (1+ (ccl::function-source-line fspec))) + (list :function-name (princ-to-string + (function-name fspec)))))) + (error (c) (list :error (princ-to-string c)))) + (list :error (format nil "No source information available for ~S" + fspec))))) + +(defimplementation find-definitions (name) + (list (list name (fspec-location name)))) + +(defimplementation arglist (name) + (handler-case + (cond ((and (symbolp name) + (macro-function name)) + (ccl::macro-lambda-list (symbol-function name))) + (t + (when (symbolp name) + (setq name (symbol-function name))) + (if (eq (class-of name) cl::the-class-standard-gf) + (generic-function-lambda-list name) + (ccl:function-lambda-list name)))) + (error () :not-available))) + +(defimplementation function-name (fn) + (handler-case (getf (cl::function-info-list fn) 'cl::function-name) + (error () nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +;;; Compiler + +(defvar *buffer-name* nil) +(defvar *buffer-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +;; FIXME +(defimplementation call-with-compilation-hooks (FN) + (handler-bind ((error (lambda (c) + (signal (make-condition + 'compiler-condition + :original-condition c + :severity :warning + :message (format nil "~A" c) + :location + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :position *buffer-position*))) + (*compile-filename* + (make-location + (list :file *compile-filename*) + (list :position 1))) + (t + (list :error "No location")))))))) + (funcall fn))) + +(defimplementation swank-compile-file (*compile-filename* load-p + external-format) + (declare (ignore external-format)) + (with-compilation-hooks () + (let ((*buffer-name* nil)) + (compile-file *compile-filename*) + (when load-p + (load (compile-file-pathname *compile-filename*)))))) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-position* position) + (*buffer-string* string)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string))))))) + +;;;; Inspecting + +;; Hack to make swank.lisp load, at least +(defclass file-stream ()) + +(defclass corman-inspector (backend-inspector) + ()) + +(defimplementation make-default-inspector () + (make-instance 'corman-inspector)) + +(defun comma-separated (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast (loop for e in list + collect (funcall callback e) + collect ", "))) + +(defmethod inspect-for-emacs ((class standard-class) + (inspector backend-inspector)) + (declare (ignore inspector)) + (values "A class." + `("Name: " (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(comma-separated (swank-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(comma-separated + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(princ-to-string + (swank-mop:slot-definition-name slot))))) + '("#<N/A (class not finalized)>")) + (:newline) + ,@(when (documentation class t) + `("Documentation:" (:newline) ,(documentation class t) (:newline))) + "Sub classes: " + ,@(comma-separated (swank-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub ,(princ-to-string (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class ,(princ-to-string (class-name class))))) + '("#<N/A (class not finalized)>")) + (:newline)))) + +(defmethod inspect-for-emacs ((slot cons) (inspector backend-inspector)) + ;; Inspects slot definitions + (declare (ignore inspector)) + (if (eq (car slot) :name) + (values "A slot." + `("Name: " (:value ,(swank-mop:slot-definition-name slot)) + (:newline) + ,@(when (swank-mop:slot-definition-documentation slot) + `("Documentation:" (:newline) + (:value ,(swank-mop:slot-definition-documentation slot)) + (:newline))) + "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline) + "Init form: " ,(if (swank-mop:slot-definition-initfunction slot) + `(:value ,(swank-mop:slot-definition-initform slot)) + "#<unspecified>") (:newline) + "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) + (:newline))) + (call-next-method))) + +(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal) + inspector) + (declare (ignore inspector)) + (values (if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + (append (label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname)))))) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (cond ((cl::structurep o) (inspect-structure o)) + (t (call-next-method)))) + +(defun inspect-structure (o) + (values + (format nil "~A is a structure" o) + (let* ((template (cl::uref o 1)) + (num-slots (cl::struct-template-num-slots template))) + (cond ((symbolp template) + (loop for i below num-slots + append (label-value-line i (cl::uref o (+ 2 i))))) + (t + (loop for i below num-slots + append (label-value-line (elt template (+ 6 (* i 5))) + (cl::uref o (+ 2 i))))))))) + + +;;; Threads + +(require 'threads) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + (lock (make-instance 'threads:critical-section)) + (queue '() :type list)) + +(defvar *mailbox-lock* (make-instance 'threads:critical-section)) +(defvar *mailboxes* (list)) + +(defmacro with-lock (lock &body body) + `(threads:with-synchronization (threads:cs ,lock) + ,@body)) + +(defimplementation spawn (fun &key name) + (declare (ignore name)) + (th:create-thread + (lambda () + (handler-bind ((serious-condition #'invoke-debugger)) + (unwind-protect (funcall fun) + (with-lock *mailbox-lock* + (setq *mailboxes* (remove cormanlisp:*current-thread-id* + *mailboxes* :key #'mailbox.thread)))))))) + +(defimplementation thread-id (thread) + thread) + +(defimplementation find-thread (thread) + (if (thread-alive-p thread) + thread)) + +(defimplementation thread-alive-p (thread) + (if (threads:thread-handle thread) t nil)) + +(defimplementation current-thread () + cormanlisp:*current-thread-id*) + +;; XXX implement it +(defimplementation all-threads () + '()) + +;; XXX something here is broken +(defimplementation kill-thread (thread) + (threads:terminate-thread thread 'killed)) + +(defun mailbox (thread) + (with-lock *mailbox-lock* + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (with-lock (mailbox.lock mbox) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(defimplementation receive () + (let ((mbox (mailbox cormanlisp:*current-thread-id*))) + (loop + (with-lock (mailbox.lock mbox) + (when (mailbox.queue mbox) + (return (pop (mailbox.queue mbox))))) + (sleep 0.1)))) + + +;;; This is probably not good, but it WFM +(in-package :common-lisp) + +(defvar *old-documentation* #'documentation) +(defun documentation (thing &optional (type 'function)) + (if (symbolp thing) + (funcall *old-documentation* thing type) + (values))) + +(defmethod print-object ((restart restart) stream) + (if (or *print-escape* + *print-readably*) + (print-unreadable-object (restart stream :type t :identity t) + (princ (restart-name restart) stream)) + (when (functionp (restart-report-function restart)) + (funcall (restart-report-function restart) stream))))
Added: branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,246 @@ +;;;; -*- 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 + +(in-package :swank-backend) + +(import-from :ext *gray-stream-symbols* :swank-backend) + +(swank-backend::import-swank-mop-symbols :clos + '(:eql-specializer + :eql-specializer-object + :generic-function-declarations + :specializer-direct-methods + :compute-applicable-methods-using-classes)) + + +;;;; TCP Server + +(require 'sockets) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket 5) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore buffering timeout external-format)) + (make-socket-io-stream (accept socket))) + +(defun make-socket-io-stream (socket) + (sb-bsd-sockets:socket-make-stream socket + :output t + :input t + :element-type 'base-char)) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation preferred-communication-style () + (values nil)) + + +;;;; Unix signals + +(defimplementation getpid () + (si:getpid)) + +#+nil +(defimplementation set-default-directory (directory) + (ext::chdir (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (ext::getcwd)) + (default-directory)) + +#+nil +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation quit-lisp () + (ext:quit)) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(defun signal-compiler-condition (&rest args) + (signal (apply #'make-condition 'compiler-condition args))) + +(defun handle-compiler-warning (condition) + (signal-compiler-condition + :original-condition condition + :message (format nil "~A" condition) + :severity :warning + :location + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :position *buffer-start-position*)) + ;; ;; compiler::*current-form* + ;; (if compiler::*current-function* + ;; (make-location (list :file *compile-filename*) + ;; (list :function-name + ;; (symbol-name + ;; (slot-value compiler::*current-function* + ;; 'compiler::name)))) + (list :error "No location found.") + ;; ) + ))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-compiler-warning)) + (funcall function))) + +(defimplementation swank-compile-file (*compile-filename* load-p + external-format) + (declare (ignore external-format)) + (with-compilation-hooks () + (let ((*buffer-name* nil)) + (multiple-value-bind (fn warn fail) + (compile-file *compile-filename*) + (when load-p (unless fail (load fn))))))) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (with-input-from-string (s string) + (compile-from-stream s :load t))))) + +(defun compile-from-stream (stream &rest args) + (let ((file (si::mkstemp "TMP:ECLXXXXXX"))) + (with-open-file (s file :direction :output :if-exists :overwrite) + (do ((line (read-line stream nil) (read-line stream nil))) + ((not line)) + (write-line line s))) + (unwind-protect + (apply #'compile-file file args) + (delete-file file)))) + + +;;;; Documentation + +(defimplementation arglist (name) + (or (functionp name) (setf name (symbol-function name))) + (if (functionp name) + (typecase name + (generic-function + (clos::generic-function-lambda-list name)) + (function + (let ((fle (function-lambda-expression name))) + (case (car fle) + (si:lambda-block (caddr fle)) + (t :not-available))))) + :not-available)) + +(defimplementation function-name (f) + (si:compiled-function-name f)) + +(defimplementation macroexpand-all (form) + ;;; FIXME! This is not the same as a recursive macroexpansion! + (macroexpand form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (dolist (type '(:VARIABLE :FUNCTION :CLASS)) + (let ((doc (describe-definition symbol type))) + (when doc + (setf result (list* type doc result))))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +;;; Debugging + +(import + '(si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands)) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*tpl-commands* si::tpl-commands) + (*ihs-top* (ihs-top 'call-with-debugging-environment)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*read-suppress* nil) + (*tpl-level* (1+ *tpl-level*))) + (set-break-env) + (set-current-ihs) + (funcall debugger-loop-fn))) + +;; (defimplementation call-with-debugger-hook (hook fun) +;; (let ((*debugger-hook* hook)) +;; (funcall fun))) + +(defun nth-frame (n) + (cond ((>= n *ihs-top* ) nil) + (t (- *ihs-top* n)))) + +(defimplementation compute-backtrace (start end) + (loop for i from start below end + for f = (nth-frame i) + while f + collect f)) + +(defimplementation print-frame (frame stream) + (format stream "~A" (si::ihs-fname frame))) + +;;;; Inspector + +(defclass ecl-inspector (inspector) + ()) + +(defimplementation make-default-inspector () + (make-instance 'ecl-inspector)) + +;;;; Definitions + +(defimplementation find-definitions (name) nil)
Added: branches/trunk-reorg/thirdparty/slime/swank-gray.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-gray.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-gray.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,168 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; swank-gray.lisp --- Gray stream based IO redirection. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package :swank-backend) + +(defclass slime-output-stream (fundamental-character-output-stream) + ((output-fn :initarg :output-fn) + (buffer :initform (make-string 8000)) + (fill-pointer :initform 0) + (column :initform 0) + (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) + (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)) + (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)) + (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) + (lock :initform (make-lock :name "buffer read lock")))) + +(defmethod stream-read-char ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index 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)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (< index (length buffer)))))) + +(defmethod stream-unread-char ((s slime-input-stream) char) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (decf index) + (cond ((eql (aref buffer index) char) + (setf (aref buffer index) char)) + (t + (warn "stream-unread-char: ignoring ~S (expected ~S)" + char (aref buffer index))))))) + nil) + +(defmethod stream-clear-input ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (setf buffer "" + index 0)))) + nil) + +(defmethod stream-line-column ((s slime-input-stream)) + nil) + +(defmethod stream-line-length ((s slime-input-stream)) + 75) + + +;;; CLISP extensions + +;; We have to define an additional method for the sake of the C +;; function listen_char (see src/stream.d), on which SYS::READ-FORM +;; depends. + +;; We could make do with either of the two methods below. + +(defmethod stream-read-char-no-hang ((s slime-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (when (< index (length buffer)) + (prog1 (aref buffer index) (incf index))))))) + +;; This CLISP extension is what listen_char actually calls. The +;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit +;; more efficient to define it directly. + +(defmethod stream-read-char-will-hang-p ((s slime-input-stream)) + (with-slots (buffer index) s + (= index (length buffer)))) + + +;;; +(defimplementation make-fn-streams (input-fn output-fn) + (let* ((output (make-instance 'slime-output-stream + :output-fn output-fn)) + (input (make-instance 'slime-input-stream + :input-fn input-fn + :output-stream output))) + (values input output))) \ No newline at end of file
Added: branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,803 @@ +;;; -*- indent-tabs-mode: nil -*- +;;; +;;; swank-lispworks.lisp --- LispWorks specific code for SLIME. +;;; +;;; Created 2003, Helmut Eller +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package :swank-backend) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm") + (import-from :stream *gray-stream-symbols* :swank-backend)) + +(import-swank-mop-symbols :clos '(:slot-definition-documentation + :eql-specializer + :eql-specializer-object + :compute-applicable-methods-using-classes)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + +(defun swank-mop:compute-applicable-methods-using-classes (gf classes) + (clos::compute-applicable-methods-from-classes gf classes)) + +;; lispworks doesn't have the eql-specializer class, it represents +;; them as a list of `(EQL ,OBJECT) +(deftype swank-mop:eql-specializer () 'cons) + +(defun swank-mop:eql-specializer-object (eql-spec) + (second eql-spec)) + +(when (fboundp 'dspec::define-dspec-alias) + (dspec::define-dspec-alias defimplementation (name args &rest body) + `(defmethod ,name ,args ,@body))) + +;;; TCP server + +(defimplementation preferred-communication-style () + :spawn) + +(defun socket-fd (socket) + (etypecase socket + (fixnum socket) + (comm:socket-stream (comm:socket-stream-socket socket)))) + +(defimplementation create-socket (host port) + (multiple-value-bind (socket where errno) + #-(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port :address host) + #+(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port) + (cond (socket socket) + (t (error 'network-error + :format-control "~A failed: ~A (~D)" + :format-arguments (list where + (list #+unix (lw:get-unix-error errno)) + errno)))))) + +(defimplementation local-port (socket) + (nth-value 1 (comm:get-socket-address (socket-fd socket)))) + +(defimplementation close-socket (socket) + (comm::close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout external-format)) + (let* ((fd (comm::get-fd-from-socket socket))) + (assert (/= fd -1)) + (make-instance 'comm:socket-stream :socket fd :direction :io + :element-type 'base-char))) + +(defun set-sigint-handler () + ;; Set SIGINT handler on Swank request handler thread. + #-win32 + (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 () + (with-simple-restart (continue "Continue from SIGINT handler.") + (invoke-debugger "SIGINT"))) + +(defun make-sigint-handler (process) + (lambda (&rest args) + (declare (ignore args)) + (mp:process-interrupt process #'sigint-handler))) + +(defimplementation call-without-interrupts (fn) + (lw:without-interrupts (funcall fn))) + +(defimplementation getpid () + #+win32 (win32:get-current-process-id) + #-win32 (system::getpid)) + +(defimplementation lisp-implementation-type-name () + "lispworks") + +(defimplementation set-default-directory (directory) + (namestring (hcl:change-directory directory))) + +;;;; Documentation + +(defimplementation arglist (symbol-or-function) + (let ((arglist (lw:function-lambda-list symbol-or-function))) + (etypecase arglist + ((member :dont-know) + :not-available) + (list + arglist)))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form) + (walker:walk-form form)) + +(defun generic-function-p (object) + (typep object 'generic-function)) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (labels ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos)))) + (doc (kind &optional (sym symbol)) + (let ((string (documentation sym kind))) + (if string + (first-line string) + :not-documented))) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :generic-function (if (and (fboundp symbol) + (generic-function-p (fdefinition symbol))) + (doc 'function))) + (maybe-push + :function (if (and (fboundp symbol) + (not (generic-function-p (fdefinition symbol)))) + (doc 'function))) + (maybe-push + :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol)))) + (if (fboundp setf-name) + (doc 'setf)))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol type) + (ecase type + (:variable (describe-symbol symbol)) + (:class (describe (find-class symbol))) + ((:function :generic-function) (describe-function symbol)) + (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol)))))) + +(defun describe-function (symbol) + (cond ((fboundp symbol) + (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%" + (string-downcase symbol) + (mapcar #'string-upcase + (lispworks:function-lambda-list symbol)) + (documentation symbol 'function)) + (describe (fdefinition symbol))) + (t (format t "~S is not fbound" symbol)))) + +(defun describe-symbol (sym) + (format t "~A is a symbol in package ~A." sym (symbol-package sym)) + (when (boundp sym) + (format t "~%~%Value: ~A" (symbol-value sym))) + (let ((doc (documentation sym 'variable))) + (when doc + (format t "~%~%Variable documentation:~%~A" doc))) + (when (fboundp sym) + (describe-function sym))) + +;;; Debugging + +(defclass slime-env (env:environment) + ((debugger-hook :initarg :debugger-hoook))) + +(defun slime-env (hook io-bindings) + (make-instance 'slime-env :name "SLIME Environment" + :io-bindings io-bindings + :debugger-hoook hook)) + +(defmethod env-internals:environment-display-notifier + ((env slime-env) &key restarts condition) + (declare (ignore restarts)) + (funcall (slot-value env 'debugger-hook) condition *debugger-hook*)) + +(defmethod env-internals:environment-display-debugger ((env slime-env)) + *debug-io*) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook)) + (env:with-environment ((slime-env hook '())) + (funcall fun)))) + +(defvar *sldb-top-frame*) + +(defun interesting-frame-p (frame) + (cond ((or (dbg::call-frame-p frame) + (dbg::derived-call-frame-p frame) + (dbg::foreign-frame-p frame) + (dbg::interpreted-call-frame-p frame)) + t) + ((dbg::catch-frame-p frame) dbg:*print-catch-frames*) + ((dbg::binding-frame-p frame) dbg:*print-binding-frames*) + ((dbg::handler-frame-p frame) dbg:*print-handler-frames*) + ((dbg::restart-frame-p frame) dbg:*print-restart-frames*) + ((dbg::open-frame-p frame) dbg:*print-open-frames*) + (t nil))) + +(defun nth-next-frame (frame n) + "Unwind FRAME N times." + (do ((frame frame (dbg::frame-next frame)) + (i n (if (interesting-frame-p frame) (1- i) i))) + ((or (not frame) + (and (interesting-frame-p frame) (zerop i))) + frame))) + +(defun nth-frame (index) + (nth-next-frame *sldb-top-frame* index)) + +(defun find-top-frame () + "Return the most suitable top-frame for the debugger." + (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*) + (nth-next-frame frame 1))) + ((or (null frame) ; no frame found! + (and (dbg::call-frame-p frame) + (eq (dbg::call-frame-function-name frame) + 'invoke-debugger))) + (nth-next-frame frame 1))) + ;; if we can't find a invoke-debugger frame, take any old frame at the top + (dbg::debugger-stack-current-frame dbg::*debugger-stack*))) + +(defimplementation call-with-debugging-environment (fn) + (dbg::with-debugger-stack () + (let ((*sldb-top-frame* (find-top-frame))) + (funcall fn)))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum)) + (backtrace '())) + (do ((frame (nth-frame start) (dbg::frame-next frame)) + (i start)) + ((or (not frame) (= i end)) (nreverse backtrace)) + (when (interesting-frame-p frame) + (incf i) + (push frame backtrace))))) + +(defun frame-actual-args (frame) + (let ((*break-on-signals* nil)) + (mapcar (lambda (arg) + (case arg + ((&rest &optional &key) arg) + (t + (handler-case (dbg::dbg-eval arg frame) + (error (e) (format nil "<~A>" arg)))))) + (dbg::call-frame-arglist frame)))) + +(defimplementation print-frame (frame stream) + (cond ((dbg::call-frame-p frame) + (format stream "~S ~S" + (dbg::call-frame-function-name frame) + (frame-actual-args frame))) + (t (princ frame stream)))) + +(defun frame-vars (frame) + (first (dbg::frame-locals-format-list frame #'list 75 0))) + +(defimplementation frame-locals (n) + (let ((frame (nth-frame n))) + (if (dbg::call-frame-p frame) + (mapcar (lambda (var) + (destructuring-bind (name value symbol location) var + (declare (ignore name location)) + (list :name symbol :id 0 + :value value))) + (frame-vars frame))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (destructuring-bind (_n value _s _l) (nth var (frame-vars frame)) + (declare (ignore _n _s _l)) + value))) + +(defimplementation frame-catch-tags (index) + (declare (ignore index)) + nil) + +(defimplementation frame-source-location-for-emacs (frame) + (let ((frame (nth-frame frame)) + (callee (if (plusp frame) (nth-frame (1- frame))))) + (if (dbg::call-frame-p frame) + (let ((dspec (dbg::call-frame-function-name frame)) + (cname (and (dbg::call-frame-p callee) + (dbg::call-frame-function-name callee)))) + (if dspec + (frame-location dspec cname)))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::dbg-eval form frame))) + +(defimplementation return-from-frame (frame-number form) + (let* ((frame (nth-frame frame-number)) + (return-frame (dbg::find-frame-for-return frame))) + (dbg::dbg-return-from-call-frame frame form return-frame + dbg::*debugger-stack*))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::restart-frame frame :same-args t))) + +;;; Definition finding + +(defun frame-location (dspec callee-name) + (let ((infos (dspec:find-dspec-locations dspec))) + (cond (infos + (destructuring-bind ((rdspec location) &rest _) infos + (declare (ignore _)) + (let ((name (and callee-name (symbolp callee-name) + (string callee-name)))) + (make-dspec-location rdspec location + `(:call-site ,name))))) + (t + (list :error (format nil "Source location not available for: ~S" + dspec)))))) + +(defimplementation find-definitions (name) + (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name))) + (loop for (dspec location) in locations + collect (list dspec (make-dspec-location dspec location))))) + + +;;; Compilation + +(defmacro with-swank-compilation-unit ((location &rest options) &body body) + (lw:rebinding (location) + `(let ((compiler::*error-database* '())) + (with-compilation-unit ,options + ,@body + (signal-error-data-base compiler::*error-database* ,location) + (signal-undefined-functions compiler::*unknown-functions* ,location))))) + +(defimplementation swank-compile-file (filename load-p external-format) + (with-swank-compilation-unit (filename) + (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.") + +(defvar *undefined-functions-hash* nil + "Hash table to map info about undefined functions to pathnames.") + +(lw:defadvice (compile-file compile-file-and-collect-notes :around) + (pathname &rest rest) + (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest) + (when *within-call-with-compilation-hooks* + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (let ((unfun-info (list unfun dspec))) + (unless (gethash unfun-info *undefined-functions-hash*) + (setf (gethash unfun-info *undefined-functions-hash*) + pathname))))) + compiler::*unknown-functions*)))) + +(defimplementation call-with-compilation-hooks (function) + (let ((compiler::*error-database* '()) + (*undefined-functions-hash* (make-hash-table :test 'equal)) + (*within-call-with-compilation-hooks* t)) + (with-compilation-unit () + (prog1 (funcall function) + (signal-error-data-base compiler::*error-database*) + (signal-undefined-functions compiler::*unknown-functions*))))) + +(defun map-error-database (database fn) + (loop for (filename . defs) in database do + (loop for (dspec . conditions) in defs do + (dolist (c conditions) + (funcall fn filename dspec c))))) + +(defun lispworks-severity (condition) + (cond ((not condition) :warning) + (t (etypecase condition + (error :error) + (style-warning :warning) + (warning :warning))))) + +(defun signal-compiler-condition (message location condition) + (check-type message string) + (signal + (make-instance 'compiler-condition :message message + :severity (lispworks-severity condition) + :location location + :original-condition condition))) + +(defun compile-from-temp-file (string filename) + (unwind-protect + (progn + (with-open-file (s filename :direction :output :if-exists :supersede) + (write-string string s) + (finish-output s)) + (let ((binary-filename (compile-file filename :load t))) + (when binary-filename + (delete-file binary-filename)))) + (delete-file filename))) + +(defun dspec-buffer-position (dspec offset) + (etypecase dspec + (cons (let ((name (dspec:dspec-primary-name dspec))) + (typecase name + ((or symbol string) + (list :function-name (string name))) + (t (list :position offset))))) + (null (list :position offset)) + (symbol (list :function-name (string dspec))))) + +(defmacro with-fairly-standard-io-syntax (&body body) + "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*." + (let ((package (gensym)) + (readtable (gensym))) + `(let ((,package *package*) + (,readtable *readtable*)) + (with-standard-io-syntax + (let ((*package* ,package) + (*readtable* ,readtable)) + ,@body))))) + +#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3 +(defun dspec-stream-position (stream dspec) + (with-fairly-standard-io-syntax + (loop (let* ((pos (file-position stream)) + (form (read stream nil '#1=#:eof))) + (when (eq form '#1#) + (return nil)) + (labels ((check-dspec (form) + (when (consp form) + (let ((operator (car form))) + (case operator + ((progn) + (mapcar #'check-dspec + (cdr form))) + ((eval-when locally macrolet symbol-macrolet) + (mapcar #'check-dspec + (cddr form))) + ((in-package) + (let ((package (find-package (second form)))) + (when package + (setq *package* package)))) + (otherwise + (let ((form-dspec (dspec:parse-form-dspec form))) + (when (dspec:dspec-equal dspec form-dspec) + (return pos))))))))) + (check-dspec form)))))) + +(defun dspec-file-position (file dspec) + (let* ((*compile-file-pathname* (pathname file)) + (*compile-file-truename* (truename *compile-file-pathname*)) + (*load-pathname* *compile-file-pathname*) + (*load-truename* *compile-file-truename*)) + (with-open-file (stream file) + (let ((pos + #-(or lispworks4.1 lispworks4.2) + (dspec-stream-position stream dspec))) + (if pos + (list :position (1+ pos) t) + (dspec-buffer-position dspec 1)))))) + +(defun emacs-buffer-location-p (location) + (and (consp location) + (eq (car location) :emacs-buffer))) + +(defun make-dspec-location (dspec location &optional hints) + (etypecase location + ((or pathname string) + (multiple-value-bind (file err) + (ignore-errors (namestring (truename location))) + (if err + (list :error (princ-to-string err)) + (make-location `(:file ,file) + (dspec-file-position file dspec) + hints)))) + (symbol + `(:error ,(format nil "Cannot resolve location: ~S" location))) + ((satisfies emacs-buffer-location-p) + (destructuring-bind (_ buffer offset string) location + (declare (ignore _ string)) + (make-location `(:buffer ,buffer) + (dspec-buffer-position dspec offset) + hints))))) + +(defun make-dspec-progenitor-location (dspec location) + (let ((canon-dspec (dspec:canonicalize-dspec dspec))) + (make-dspec-location + (if canon-dspec + (if (dspec:local-dspec-p canon-dspec) + (dspec:dspec-progenitor canon-dspec) + canon-dspec) + nil) + location))) + +(defun signal-error-data-base (database &optional location) + (map-error-database + database + (lambda (filename dspec condition) + (signal-compiler-condition + (format nil "~A" condition) + (make-dspec-progenitor-location dspec (or location filename)) + condition)))) + +(defun unmangle-unfun (symbol) + "Converts symbols like 'SETF::|"CL-USER" "GET"| to +function names like (SETF GET)." + (or (and (eq (symbol-package symbol) + (load-time-value (find-package :setf))) + (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 (slime-nregex:regex-compile "^"(.+)" "(.+)"$"))) + symbol-name) + (list 'setf + (intern (apply #'subseq symbol-name + (aref slime-nregex::*regex-groups* 2)) + (find-package + (apply #'subseq symbol-name + (aref slime-nregex::*regex-groups* 1)))))))) + symbol)) + +(defun signal-undefined-functions (htab &optional filename) + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (signal-compiler-condition + (format nil "Undefined function ~A" (unmangle-unfun unfun)) + (make-dspec-progenitor-location dspec + (or filename + (gethash (list unfun dspec) + *undefined-functions-hash*))) + nil))) + htab)) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (assert buffer) + (assert position) + (let* ((location (list :emacs-buffer buffer position string)) + (tmpname (hcl:make-temp-file nil "lisp"))) + (with-swank-compilation-unit (location) + (compile-from-temp-file + (with-output-to-string (s) + (let ((*print-radix* t)) + (print `(eval-when (:compile-toplevel) + (setq dspec::*location* (list ,@location))) + s)) + (write-string string s)) + tmpname)))) + +;;; xref + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls hcl:who-calls) +(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too +(defxref calls-who hcl:calls-who) +(defxref list-callers list-callers-internal) +;; (defxref list-callees list-callees-internal) + +(defun list-callers-internal (name) + (let ((callers (make-array 100 + :fill-pointer 0 + :adjustable t))) + (hcl:sweep-all-objects + #'(lambda (object) + (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object) + #-Harlequin-PC-Lisp (sys::callablep object) + (system::find-constant$funcallable name object)) + (vector-push-extend object callers)))) + ;; Delay dspec:object-dspec until after sweep-all-objects + ;; to reduce allocation problems. + (loop for object across callers + collect (if (symbolp object) + (list 'function object) + (or (dspec:object-dspec object) object))))) + +;; only for lispworks 4.2 and above +#-lispworks4.1 +(progn + (defxref who-references hcl:who-references) + (defxref who-binds hcl:who-binds) + (defxref who-sets hcl:who-sets)) + +(defimplementation who-specializes (classname) + (let ((methods (clos:class-direct-methods (find-class classname)))) + (xref-results (mapcar #'dspec:object-dspec methods)))) + +(defun xref-results (dspecs) + (flet ((frob-locs (dspec locs) + (cond (locs + (loop for (name loc) in locs + collect (list name (make-dspec-location name loc)))) + (t `((,dspec (:error "Source location not available"))))))) + (loop for dspec in dspecs + append (frob-locs dspec (dspec:dspec-definition-locations dspec))))) + +;;; Inspector +(defclass lispworks-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'lispworks-inspector)) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (declare (ignore inspector)) + (lispworks-inspect o)) + +(defmethod inspect-for-emacs ((o function) + (inspector backend-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 backend-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) + (declare (ignore _getter _setter)) + (values "A value." + (append + (label-value-line "Type" type) + (loop for name in names + for value in values + append (label-value-line name value)))))) + +;;; Miscellaneous + +(defimplementation quit-lisp () + (lispworks:quit)) + +;;; Tracing + +(defun parse-fspec (fspec) + "Return a dspec for FSPEC." + (ecase (car fspec) + ((:defmethod) `(method ,(cdr fspec))))) + +(defun tracedp (dspec) + (member dspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (dspec) + (cond ((tracedp dspec) + (eval `(untrace ,dspec)) + (format nil "~S is now untraced." dspec)) + (t + (eval `(trace (,dspec))) + (format nil "~S is now traced." dspec)))) + +(defimplementation toggle-trace (fspec) + (toggle-trace-aux (parse-fspec fspec))) + +;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (cond ((not mp::*multiprocessing*) + (push (list "Initialize SLIME" '() continuation) + mp:*initial-processes*) + (mp:initialize-multiprocessing)) + (t (funcall continuation)))) + +(defimplementation spawn (fn &key name) + (let ((mp:*process-initial-bindings* + (remove (find-package :cl) + mp:*process-initial-bindings* + :key (lambda (x) (symbol-package (car x)))))) + (mp:process-run-function name () fn))) + +(defvar *id-lock* (mp:make-lock)) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-lock (*id-lock*) + (or (getf (mp:process-plist thread) 'id) + (setf (getf (mp:process-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (mp:list-all-processes) + :key (lambda (p) (getf (mp:process-plist p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A ~D" + (mp:process-whostate thread) + (mp:process-priority thread))) + +(defimplementation make-lock (&key name) + (mp:make-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (mp:list-all-processes)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defimplementation thread-alive-p (thread) + (mp:process-alive-p thread)) + +(defvar *mailbox-lock* (mp:make-lock)) + +(defun mailbox (thread) + (mp:with-lock (*mailbox-lock*) + (or (getf (mp:process-plist thread) 'mailbox) + (setf (getf (mp:process-plist thread) 'mailbox) + (mp:make-mailbox))))) + +(defimplementation receive () + (mp:mailbox-read (mailbox mp:*current-process*))) + +(defimplementation send (thread object) + (mp:mailbox-send (mailbox thread) object)) + +;;; Some intergration with the lispworks environment + +(defun swank-sym (name) (find-symbol (string name) :swank)) + +(defimplementation emacs-connected () + (when (eq (eval (swank-sym :*communication-style*)) + nil) + (set-sigint-handler)) + ;; pop up the slime debugger by default + (let ((lw:*handle-warn-on-redefinition* :warn)) + (defmethod env-internals:environment-display-notifier + (env &key restarts condition) + (declare (ignore restarts)) + (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)) + (defmethod env-internals:environment-display-debugger (env) + *debug-io*))) + +(defimplementation make-stream-interactive (stream) + (unless (find-method #'stream:stream-soft-force-output nil `((eql ,stream)) + nil) + (let ((lw:*handle-warn-on-redefinition* :warn)) + (defmethod stream:stream-soft-force-output ((o (eql stream))) + (force-output o))))) + +(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) + (apply (swank-sym :y-or-n-p-in-emacs) msg args)) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :value args))
Added: branches/trunk-reorg/thirdparty/slime/swank-loader.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-loader.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-loader.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,236 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; swank-loader.lisp --- Compile and load the Slime backend. +;;; +;;; Created 2003, James Bielman jamesjb@jamesjb.com +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;; If you want customize the source- or fasl-directory you can set +;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory* +;; before loading this files. (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 :cl) + (:export :load-swank + :*source-directory* + :*fasl-directory*)) + +(cl:in-package :swank-loader) + +(defvar *source-directory* + (make-pathname :name nil :type nil + :defaults (or *load-pathname* *default-pathname-defaults*)) + "The directory where to look for the source.") + +(defparameter *sysdep-files* + (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-source-path-parser" "swank-source-file-cache" + "swank-sbcl" "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 :cormanlisp + :armedbear :gcl :ecl :scl)) + +(defparameter *os-features* + '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux + :unix)) + +(defparameter *architecture-features* + '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 + :sparc64 :sparc :hppa64 :hppa)) + +(defun lisp-version-string () + #+cmu (substitute-if #_ (lambda (x) (find x " /")) + (lisp-implementation-version)) + #+scl (lisp-implementation-version) + #+sbcl (lisp-implementation-version) + #+ecl (lisp-implementation-version) + #+openmcl (format nil "~d.~d" + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version*) + #+lispworks (lisp-implementation-version) + #+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) + #+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, +operating system, and hardware architecture." + (flet ((first-of (features) + (loop for f in features + when (find f *features*) return it)) + (maybe-warn (value fstring &rest args) + (cond (value) + (t (apply #'warn fstring args) + "unknown")))) + (let ((lisp (maybe-warn (first-of *implementation-features*) + "No implementation feature found in ~a." + *implementation-features*)) + (os (maybe-warn (first-of *os-features*) + "No os feature found in ~a." *os-features*)) + (arch (maybe-warn (first-of *architecture-features*) + "No architecture feature found in ~a." + *architecture-features*)) + (version (maybe-warn (lisp-version-string) + "Don't know how to get Lisp ~ + implementation version."))) + (format nil "~(~@{~a~^-~}~)" lisp version os arch)))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun 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 :name (pathname-name cfp) + :type (pathname-type cfp)) + binary-directory))) + +(defun handle-loadtime-error (condition binary-pathname) + (pprint-logical-block (*error-output* () :per-line-prefix ";; ") + (format *error-output* + "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%" + 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 load) + "Compile each file in FILES if the source is newer than +its corresponding binary, or the file preceding it was +recompiled." + (let ((needs-recompile nil)) + (dolist (source-pathname files) + (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)) + (when load + (load binary-pathname :verbose t))) + ;; Fail as early as possible + (serious-condition (c) + (handle-loadtime-error c binary-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))) + +(defun load-user-init-file () + "Load the user init file, return NIL if it does not exist." + (load (merge-pathnames (user-homedir-pathname) + (make-pathname :name ".swank" :type "lisp")) + :if-does-not-exist nil)) + +(defun load-site-init-file (directory) + (load (make-pathname :name "site-init" :type "lisp" + :defaults directory) + :if-does-not-exist nil)) + +(defun source-files (names src-dir) + (mapcar (lambda (name) + (make-pathname :name (string-downcase name) :type "lisp" + :defaults src-dir)) + names)) + +(defun swank-source-files (src-dir) + (source-files `("swank-backend" ,@*sysdep-files* "swank") + src-dir)) + +(defvar *fasl-directory* (default-fasl-directory) + "The directory where fasl files should be placed.") + +(defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy + swank-fancy-inspector + swank-presentations swank-presentation-streams + #+(or asdf sbcl) swank-asdf + ) + "List of names for contrib modules.") + +(defun append-dir (absolute name) + (merge-pathnames + (make-pathname :directory `(:relative ,name) :defaults absolute) + absolute)) + +(defun contrib-src-dir (src-dir) + (append-dir src-dir "contrib")) + +(defun contrib-source-files (src-dir) + (source-files *contribs* (contrib-src-dir src-dir))) + +(defun load-swank (&key + (source-directory *source-directory*) + (fasl-directory *fasl-directory*) + (contrib-fasl-directory + (append-dir fasl-directory "contrib"))) + (compile-files-if-needed-serially (swank-source-files source-directory) + fasl-directory t) + (compile-files-if-needed-serially (contrib-source-files source-directory) + contrib-fasl-directory nil)) + +(load-swank) + +(setq swank::*swank-wire-protocol-version* (slime-version-string)) +(setq swank::*load-path* + (append swank::*load-path* (list (contrib-src-dir *source-directory*)))) +(swank-backend::warn-unimplemented-interfaces) +(load-site-init-file *source-directory*) +(load-user-init-file) +(swank:run-after-init-hook)
Added: branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,985 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; openmcl-swank.lisp --- SLIME backend for OpenMCL. +;;; +;;; Copyright (C) 2003, James Bielman jamesjb@jamesjb.com +;;; +;;; This program is licensed under the terms of the Lisp Lesser GNU +;;; Public License, known as the LLGPL, and distributed with OpenMCL +;;; as the file "LICENSE". The LLGPL consists of a preamble and the +;;; LGPL, which is distributed with OpenMCL as the file "LGPL". Where +;;; these conflict, the preamble takes precedence. +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; +;;; This is the beginning of a Slime backend for OpenMCL. It has been +;;; tested only with OpenMCL version 0.14-030901 on Darwin --- I would +;;; be interested in hearing the results with other versions. +;;; +;;; Additionally, reporting the positions of warnings accurately requires +;;; a small patch to the OpenMCL file compiler, which may be found at: +;;; +;;; http://www.jamesjb.com/slime/openmcl-warning-position.diff +;;; +;;; Things that work: +;;; +;;; * Evaluation of forms with C-M-x. +;;; * Compilation of defuns with C-c C-c. +;;; * File compilation with C-c C-k. +;;; * Most of the debugger functionality, except EVAL-IN-FRAME, +;;; FRAME-SOURCE-LOCATION, and FRAME-CATCH-TAGS. +;;; * Macroexpanding with C-c RET. +;;; * Disassembling the symbol at point with C-c M-d. +;;; * Describing symbol at point with C-c C-d. +;;; * Compiler warnings are trapped and sent to Emacs using the buffer +;;; position of the offending top level form. +;;; * Symbol completion and apropos. +;;; +;;; Things that sort of work: +;;; +;;; * WHO-CALLS is implemented but is only able to return the file a +;;; caller is defined in---source location information is not +;;; available. +;;; +;;; Things that aren't done yet: +;;; +;;; * Cross-referencing. +;;; * Due to unimplementation functionality the test suite does not +;;; run correctly (it hangs upon entering the debugger). +;;; + +(in-package :swank-backend) + +(import-from :ccl *gray-stream-symbols* :swank-backend) + +(require 'xref) + +;;; swank-mop + +(import-to-swank-mop + '( ;; classes + cl:standard-generic-function + ccl::standard-slot-definition + cl:method + cl:standard-class + ccl::eql-specializer + openmcl-mop:finalize-inheritance + ;; standard-class readers + openmcl-mop:class-default-initargs + openmcl-mop:class-direct-default-initargs + openmcl-mop:class-direct-slots + openmcl-mop:class-direct-subclasses + openmcl-mop:class-direct-superclasses + openmcl-mop:class-finalized-p + cl:class-name + openmcl-mop:class-precedence-list + openmcl-mop:class-prototype + openmcl-mop:class-slots + openmcl-mop:specializer-direct-methods + ;; eql-specializer accessors + openmcl-mop:eql-specializer-object + ;; generic function readers + openmcl-mop:generic-function-argument-precedence-order + openmcl-mop:generic-function-declarations + openmcl-mop:generic-function-lambda-list + openmcl-mop:generic-function-methods + openmcl-mop:generic-function-method-class + openmcl-mop:generic-function-method-combination + openmcl-mop:generic-function-name + ;; method readers + openmcl-mop:method-generic-function + openmcl-mop:method-function + openmcl-mop:method-lambda-list + openmcl-mop:method-specializers + openmcl-mop:method-qualifiers + ;; slot readers + openmcl-mop:slot-definition-allocation + 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-boundp-using-class + openmcl-mop:slot-makunbound-using-class)) + +(defun specializer-name (spec) + (etypecase spec + (cons 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 () + :spawn) + +(defimplementation create-socket (host port) + (ccl:make-socket :connect :passive :local-port port + :local-host host :reuse-address t)) + +(defimplementation local-port (socket) + (ccl:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format + buffering timeout) + (declare (ignore buffering timeout + #-openmcl-unicode-strings external-format)) + #+openmcl-unicode-strings + (when external-format + (let ((keys (ccl::socket-keys socket))) + (setf (getf keys :external-format) external-format + (slot-value socket 'ccl::keys) keys))) + (ccl:accept-connection socket :wait t)) + +#+openmcl-unicode-strings +(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"))) + +#+openmcl-unicode-strings +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation emacs-connected () + (setq ccl::*interactive-abort-process* ccl::*current-process*)) + +(defimplementation make-stream-interactive (stream) + (typecase stream + (ccl:fundamental-output-stream + (push stream ccl::*auto-flush-streams*)))) + +;;; Unix signals + +(defimplementation call-without-interrupts (fn) + (ccl:without-interrupts (funcall fn))) + +(defimplementation getpid () + (ccl::getpid)) + +(defimplementation lisp-implementation-type-name () + "openmcl") + +(defvar *break-in-sldb* t) + +(let ((ccl::*warn-if-redefine-kernel* nil)) + (ccl::advise + cl::break + (if (and *break-in-sldb* + (find ccl::*current-process* (symbol-value (intern "*CONNECTIONS*" 'swank)) + :key (intern "CONNECTION.REPL-THREAD" 'swank))) + (apply 'break-in-sldb ccl::arglist) + (:do-it)) :when :around :name sldb-break)) + +(defun break-in-sldb (&optional string &rest args) + (let ((c (make-condition 'simple-condition + :format-control (or string "Break") + :format-arguments args))) + (let ((previous-f nil) + (previous-f2 nil)) + (block find-frame + (map-backtrace + #'(lambda(frame-number p context lfun pc) + (declare (ignore frame-number context pc)) + (when (eq previous-f2 'break-in-sldb) + (record-stack-top p) + (return-from find-frame)) + (setq previous-f2 previous-f) + (setq previous-f (ccl::lfun-name lfun))))) + (restart-case (invoke-debugger c) + (continue () :report (lambda (stream) (write-string "Resume interrupted evaluation" stream)) t)) + ))) + +; In previous version the code that recorded the function that had an +; error or which was interrupted was not thread safe. This code repairs that by +; associating the frame pointer with a process via the *process-to-stack-top* hash. + +(defvar *process-to-stack-top* (make-hash-table :test 'eql)) + +(defun record-stack-top (frame) + (setf (gethash (ccl::process-serial-number ccl::*current-process*) *process-to-stack-top* ) + frame)) + +(defun grab-stack-top () + (let ((psn (ccl::process-serial-number ccl::*current-process*))) + (ccl::without-interrupts + (prog1 + (gethash psn *process-to-stack-top*) + (setf (gethash psn *process-to-stack-top*) nil))))) + +(defmethod ccl::application-error :before (application condition error-pointer) + (declare (ignore application condition)) + (record-stack-top error-pointer) + nil) + +;;; Evaluation + +(defimplementation arglist (fname) + (arglist% fname)) + +(defmethod arglist% ((f symbol)) + (ccl:arglist f)) + +(defmethod arglist% ((f function)) + (ccl:arglist (ccl:function-name f))) + +(defimplementation function-name (function) + (ccl:function-name function)) + +;;; Compilation + +(defvar *buffer-offset* nil) +(defvar *buffer-name* nil) + +(defun condition-source-position (condition) + "Return the position in the source file of a compiler condition." + (+ 1 + (or *buffer-offset* 0) + ;; 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." + (signal (make-condition + 'compiler-condition + :original-condition condition + :message (format nil "~A" condition) + :severity :warning + :location + (let ((position (condition-source-position condition))) + (if *buffer-name* + (make-location + (list :buffer *buffer-name*) + (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)) + (funcall function))) + +(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) + (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)) + (flet ((function-source-location (entry) + (multiple-value-bind (info name) + (ccl::edit-definition-p + (ccl::%db-key-from-xref-entry entry) + (if (eql (ccl::xref-entry-type entry) + 'macro) + 'function + (ccl::xref-entry-type entry))) + (cond ((not info) + (list :error + (format nil "No source info available for ~A" + (ccl::xref-entry-name entry)))) + ((typep (caar info) 'ccl::method) + `(:location + (:file ,(remove-filename-quoting + (namestring (translate-logical-pathname + (cdr (car info)))))) + (:method + ,(princ-to-string (ccl::method-name (caar info))) + ,(mapcar 'princ-to-string + (mapcar #'specializer-name + (ccl::method-specializers + (caar info)))) + ,@(mapcar 'princ-to-string + (ccl::method-qualifiers (caar info)))) + nil)) + (t + (canonicalize-location (cdr (first info)) name)))))) + (declare (dynamic-extent #'function-source-location)) + (loop for xref in (if inverse + (ccl::get-relation relation name + :wild :exhaustive t) + (ccl::get-relation relation + :wild name :exhaustive t)) + for function = (ccl::xref-entry-name xref) + collect `((function ,function) + ,(function-source-location xref))))) + +(defimplementation who-binds (name) + (xref-locations :binds name)) + +(defimplementation who-macroexpands (name) + (xref-locations :macro-calls name t)) + +(defimplementation who-references (name) + (remove-duplicates + (append (xref-locations :references name) + (xref-locations :sets name) + (xref-locations :binds name)) + :test 'equal)) + +(defimplementation who-sets (name) + (xref-locations :sets name)) + +(defimplementation who-calls (name) + (remove-duplicates + (append + (xref-locations :direct-calls name) + (xref-locations :indirect-calls name) + (xref-locations :macro-calls name t)) + :test 'equal)) + +(defimplementation list-callees (name) + (remove-duplicates + (append + (xref-locations :direct-calls name t) + (xref-locations :macro-calls name nil)) + :test 'equal)) + +(defimplementation who-specializes (class) + (if (symbolp class) (setq class (find-class class))) + (remove-duplicates + (append (mapcar (lambda(m) + (let ((location (function-source-location (ccl::method-function m)))) + (if (eq (car location) :error) + (setq location nil )) + `((method ,(ccl::method-name m) + ,(mapcar #'specializer-name (ccl::method-specializers m)) + ,@(ccl::method-qualifiers m)) + ,location))) + (ccl::%class.direct-methods class)) + (mapcan 'who-specializes (ccl::%class-direct-subclasses class))) + :test 'equal)) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-offset* position) + (filename (temp-file-name))) + (unwind-protect + (with-open-file (s filename :direction :output :if-exists :error) + (write-string string s)) + (let ((binary-filename (compile-file filename :load t))) + (delete-file binary-filename))) + (delete-file filename)))) + +;;; Profiling (alanr: lifted from swank-clisp) + +(defimplementation profile (fname) + (eval `(mon:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + mon:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (mon:unmonitor)) + +(defimplementation profile-report () + (mon:report-monitoring)) + +(defimplementation profile-reset () + (mon:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (mon:monitor-all package)) + +;;; Debugging + +(defun openmcl-set-debug-switches () + (setq ccl::*fasl-save-definitions* nil) + (setq ccl::*fasl-save-doc-strings* t) + (setq ccl::*fasl-save-local-symbols* t) + (setq ccl::*ppc2-compiler-register-save-label* t) + (setq ccl::*save-arglist-info* t) + (setq ccl::*save-definitions* nil) + (setq ccl::*save-doc-strings* t) + (setq ccl::*save-local-symbols* t) + (ccl::start-xref)) + +(defvar *sldb-stack-top* nil) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((*debugger-hook* nil) + (*sldb-stack-top* (grab-stack-top)) + (ccl::*signal-printing-errors* nil)) ; don't let error while printing error take us down + (funcall debugger-loop-fn))) + +(defun backtrace-context () + (if (and (= ccl::*openmcl-major-version* 0) + (<= ccl::*openmcl-minor-version* 14) + (< ccl::*openmcl-revision* 2)) + (ccl::%current-tcr) + nil)) + +(defun map-backtrace (function &optional + (start-frame-number 0) + (end-frame-number most-positive-fixnum)) + "Call FUNCTION passing information about each stack frame + from frames START-FRAME-NUMBER to END-FRAME-NUMBER." + (let ((context (backtrace-context)) + (frame-number 0) + (top-stack-frame (or *sldb-stack-top* + (ccl::%get-frame-ptr)))) + (do* ((p top-stack-frame (ccl::parent-frame p context)) + (q (ccl::last-frame-ptr context))) + ((or (null p) (eq p q) (ccl::%stack< q p context)) + (values)) + (multiple-value-bind (lfun pc) (ccl::cfp-lfun p) + (when lfun + (if (and (>= frame-number start-frame-number) + (< frame-number end-frame-number)) + (funcall function frame-number p context lfun pc)) + (incf frame-number)))))) + +;; May 13, 2004 alanr: use prin1 instead of princ so I see " around strings. Write ' in front of symbol names and lists. +;; Sept 6, 2004 alanr: use builtin ccl::frame-supplied-args + +(defun frame-arguments (p context lfun pc) + "Returns a string representing the arguments of a frame." + (multiple-value-bind (args types names count nclosed) + (ccl::frame-supplied-args p lfun pc nil context) + (declare (ignore count nclosed)) + (let ((result nil)) + (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 + (when (or (symbolp var) (listp var)) (setq var (list 'quote var))) + (cond ((equal type "keyword") + (push (format nil "~S ~A" + (intern (symbol-name name) "KEYWORD") + (prin1-to-string var)) + result)) + (t (push (prin1-to-string var) result)))) + (format nil "~{ ~A~}" (nreverse result))))) + + +;; XXX should return something less stringy +;; alanr May 13, 2004: put #<> around anonymous functions in the backtrace. + +(defimplementation compute-backtrace (start-frame-number end-frame-number) + (let (result) + (map-backtrace (lambda (frame-number p context lfun pc) + (declare (ignore frame-number)) + (push (with-output-to-string (s) + (format s "(~A~A)" + (if (ccl::function-name lfun) + (ccl::%lfun-name-string lfun) + lfun) + (frame-arguments p context lfun pc))) + result)) + start-frame-number end-frame-number) + (nreverse result))) + +(defimplementation print-frame (frame stream) + (princ frame stream)) + +(defimplementation frame-locals (index) + (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) + (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)) + (block find-frame + (map-backtrace + (lambda(frame-number p context lfun pc) + (declare (ignore p context pc)) + (when (= frame-number the-frame-number) + (setq function-to-disassemble lfun) + (return-from find-frame))))) + (ccl::print-ppc-instructions + *standard-output* + (ccl::function-to-dll-header function-to-disassemble) nil))) + +;;; + +(defun canonicalize-location (file symbol) + (etypecase file + ((or string pathname) + (multiple-value-bind (truename c) (ignore-errors (namestring (truename file))) + (cond (c (list :error (princ-to-string c))) + (t (make-location (list :file (remove-filename-quoting truename)) + (list :function-name (princ-to-string symbol))))))))) + +(defun remove-filename-quoting (string) + (if (search "\" string) + (read-from-string (format nil ""~a"" string)) + string)) + +(defun maybe-method-location (type) + (when (typep type 'ccl::method) + `((method ,(ccl::method-name type) + ,(mapcar #'specializer-name (ccl::method-specializers type)) + ,@(ccl::method-qualifiers type)) + ,(function-source-location (ccl::method-function type))))) + +(defimplementation find-definitions (symbol) + (let* ((info (ccl::get-source-files-with-types&classes symbol))) + (loop for (type . file) in info + when (not (equal "l1-boot-3" (pathname-name file))) ; alanr: This is a bug - there's nothing in there + collect (or (maybe-method-location type) + (list (list type symbol) + (canonicalize-location file symbol)))))) + + +(defun function-source-location (function) + (multiple-value-bind (info name) (ccl::edit-definition-p 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))) ))) + (:method ,(princ-to-string (ccl::method-name (caar info))) + ,(mapcar 'princ-to-string + (mapcar #'specializer-name + (ccl::method-specializers (caar info)))) + ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info)))) + nil)) + (t (canonicalize-location (cdr (first info)) name))))) + +(defimplementation frame-source-location-for-emacs (index) + "Return to Emacs the location of the source code for the +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." + (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) + (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)))) + (map-backtrace + (lambda (frame-number p context lfun pc) + (declare (ignore context lfun pc)) + (when (= frame-number index) + (ccl::apply-in-frame p #'values values)))))) + +(defimplementation restart-frame (index) + (map-backtrace + (lambda (frame-number p context lfun pc) + (when (= frame-number index) + (ccl::apply-in-frame p lfun + (ccl::frame-supplied-args p lfun pc nil context)))))) + +;;; Utilities + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :setf (let ((setf-function-name (ccl::setf-function-spec-name + `(setf ,symbol)))) + (when (fboundp setf-function-name) + (doc 'function setf-function-name)))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:setf + (describe (ccl::setf-function-spec-name `(setf ,symbol)))) + (:class + (describe (find-class symbol))))) + +(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) + (loop for caller in (ccl::callers symbol) + append (multiple-value-bind (info name type specializers modifiers) + (ccl::edit-definition-p caller) + (loop for (nil . file) in info + collect (list (if (eq t type) + name + `(,type ,name ,specializers + ,@modifiers)) + (canonicalize-location file name)))))) +;;; Macroexpansion + +(defvar *value2tag* (make-hash-table)) + +(do-symbols (s (find-package 'arch)) + (if (and (> (length (symbol-name s)) 7) + (string= (symbol-name s) "SUBTAG-" :end1 7) + (boundp s) + (numberp (symbol-value s)) + (< (symbol-value s) 255)) + (setf (gethash (symbol-value s) *value2tag*) s))) + +;;;; Inspection + +(defclass openmcl-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'openmcl-inspector)) + +(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)))))) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (declare (ignore inspector)) + (let* ((i (inspector::make-inspector o)) + (count (inspector::compute-line-count i)) + (lines + (loop + for l below count + for (value label) = (multiple-value-list + (inspector::line-n i l)) + collect `(:value ,label ,(string-capitalize (format nil "~a" label))) + collect " = " + collect `(:value ,value) + collect '(:newline)))) + (values (with-output-to-string (s) + (let ((*print-lines* 1) + (*print-right-margin* 80)) + (pprint o s))) + lines))) + +(defmethod inspect-for-emacs :around ((o t) (inspector backend-inspector)) + (if (or (uvector-inspector-p o) + (not (ccl:uvectorp o))) + (call-next-method) + (multiple-value-bind (title content) + (call-next-method) + (values + title + (append content + `((:newline) + (:value ,(make-instance 'uvector-inspector :object o) + "Underlying UVECTOR"))))))) + +(defclass uvector-inspector () + ((object :initarg :object))) + +(defgeneric uvector-inspector-p (object) + (:method ((object t)) nil) + (:method ((object uvector-inspector)) t)) + +(defmethod inspect-for-emacs ((uv uvector-inspector) + (inspector backend-inspector)) + (with-slots (object) + uv + (values (format nil "The UVECTOR for ~S." object) + (loop + for index below (ccl::uvsize object) + collect (format nil "~D: " index) + 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 + "Alist (ID . PROCESS MAILBOX) list of processes that we have handed +out IDs for.") + +(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*")) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (ccl:make-lock "thread mailbox")) + (semaphore (ccl:make-semaphore)) + (queue '() :type list)) + +(defimplementation spawn (fn &key name) + (ccl:process-run-function (or name "Anonymous (Swank)") fn)) + +(defimplementation thread-id (thread) + (ccl::process-serial-number thread)) + +(defimplementation find-thread (id) + (find id (ccl:all-processes) :key #'ccl::process-serial-number)) + +(defimplementation thread-name (thread) + (ccl::process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A" (ccl:process-whostate thread))) + +(defimplementation make-lock (&key name) + (ccl:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (ccl:with-lock-grabbed (lock) + (funcall function))) + +(defimplementation current-thread () + ccl:*current-process*) + +(defimplementation all-threads () + (ccl:all-processes)) + +(defimplementation kill-thread (thread) + (ccl:process-kill thread)) + +;; September 5, 2004 alanr. record the frame interrupted +(defimplementation interrupt-thread (thread fn) + (ccl:process-interrupt + thread + (lambda(&rest args) + (let ((previous-f nil)) + (block find-frame + (map-backtrace + #'(lambda(frame-number p context lfun pc) + (declare (ignore frame-number context pc)) + (when (eq previous-f 'ccl::%pascal-functions%) + (record-stack-top p) + (return-from find-frame)) + (setq previous-f (ccl::lfun-name lfun))))) + (apply fn args))))) + + +(defun mailbox (thread) + (ccl:with-lock-grabbed (*known-processes-lock*) + (let ((probe (rassoc thread *known-processes* :key #'car))) + (cond (probe (second (cdr probe))) + (t (let ((mailbox (make-mailbox))) + (setq *known-processes* + (acons (ccl::process-serial-number thread) + (list thread mailbox) + (remove-if + (lambda(entry) + (string= (ccl::process-whostate (second entry)) "Exhausted")) + *known-processes*) + )) + mailbox)))))) + +(defimplementation send (thread message) + (assert message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (ccl:with-lock-grabbed (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (ccl:signal-semaphore (mailbox.semaphore mbox))))) + +(defimplementation receive () + (let* ((mbox (mailbox ccl:*current-process*)) + (mutex (mailbox.mutex mbox))) + (ccl:wait-on-semaphore (mailbox.semaphore mbox)) + (ccl:with-lock-grabbed (mutex) + (assert (mailbox.queue mbox)) + (pop (mailbox.queue mbox))))) + +(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)) + +(defimplementation hash-table-weakness (hashtable) + (ccl::hash-table-weak-p hashtable))
Added: branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,1323 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; swank-sbcl.lisp --- SLIME backend for SBCL. +;;; +;;; Created 2003, Daniel Barlow dan@metacircles.com +;;; +;;; This code has been placed in the Public Domain. All warranties are +;;; disclaimed. + +;;; Requires the SB-INTROSPECT contrib. + +;;; Administrivia + +(in-package :swank-backend) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'asdf) + (require 'sb-bsd-sockets) + (require 'sb-introspect) + (require 'sb-posix) + (require 'sb-cltl2)) + +(declaim (optimize (debug 2) (sb-c:insert-step-conditions 0))) + +(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))) + ;; And for xref support (1.0.1) + (defun sbcl-with-xref-p () + (if (find-symbol "WHO-CALLS" "SB-INTROSPECT") + '(:and) + '(:or))) + ;; ... for restart-frame support (1.0.2) + (defun sbcl-with-restart-frame () + (if (find-symbol "FRAME-HAS-DEBUG-TAG-P" "SB-DEBUG") + '(: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)) + +;;; TCP Server + +(defimplementation preferred-communication-style () + (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)))) + +(defimplementation create-socket (host port) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket 5) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-sys:invalidate-descriptor (socket-fd socket)) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket &key + external-format + buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (accept socket) + (or external-format :iso-latin-1-unix) + (or buffering :full))) + +(defvar *sigio-handlers* '() + "List of (key . fn) pairs to be called on SIGIO.") + +(defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (mapc (lambda (handler) + (funcall (the function (cdr handler)))) + *sigio-handlers*)) + +(defun set-sigio-handler () + (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp) + (sigio-handler signal code scp)))) + +(defun enable-sigio-on-fd (fd) + (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async) + (sb-posix::fcntl fd sb-posix::f-setown (getpid))) + +(defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (format *debug-io* "Adding sigio handler: ~S ~%" fd) + (enable-sigio-on-fd fd) + (push (cons fd fn) *sigio-handlers*))) + +(defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car)) + (sb-sys:invalidate-descriptor fd)) + (close socket)) + +(defimplementation add-fd-handler (socket 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 (_) + _ + (funcall fn))))) + +(defimplementation remove-fd-handlers (socket) + (sb-sys:invalidate-descriptor (socket-fd socket))) + +(defun socket-fd (socket) + (etypecase socket + (fixnum socket) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (sb-sys:fd-stream-fd socket)))) + +(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 + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation call-without-interrupts (fn) + (declare (type function fn)) + (sb-sys:without-interrupts (funcall fn))) + +(defimplementation getpid () + (sb-posix:getpid)) + +(defimplementation lisp-implementation-type-name () + "sbcl") + + +;;;; Support for SBCL syntax + +;;; SBCL's source code is riddled with #! reader macros. Also symbols +;;; containing `!' have special meaning. We have to work long and +;;; hard to be able to read the source. To deal with #! reader +;;; macros, we use a special readtable. The special symbols are +;;; converted by a condition handler. + +(defun feature-in-list-p (feature list) + (etypecase feature + (symbol (member feature list :test #'eq)) + (cons (flet ((subfeature-in-list-p (subfeature) + (feature-in-list-p subfeature list))) + (ecase (first feature) + (:or (some #'subfeature-in-list-p (rest feature))) + (:and (every #'subfeature-in-list-p (rest feature))) + (:not (destructuring-bind (e) (cdr feature) + (not (subfeature-in-list-p e))))))))) + +(defun shebang-reader (stream sub-character infix-parameter) + (declare (ignore sub-character)) + (when infix-parameter + (error "illegal read syntax: #~D!" infix-parameter)) + (let ((next-char (read-char stream))) + (unless (find next-char "+-") + (error "illegal read syntax: #!~C" next-char)) + ;; When test is not satisfied + ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then + ;; would become "unless test is satisfied".. + (when (let* ((*package* (find-package "KEYWORD")) + (*read-suppress* nil) + (not-p (char= next-char #-)) + (feature (read stream))) + (if (feature-in-list-p feature *features*) + not-p + (not not-p))) + ;; Read (and discard) a form from input. + (let ((*read-suppress* t)) + (read stream t nil t)))) + (values)) + +(defvar *shebang-readtable* + (let ((*readtable* (copy-readtable nil))) + (set-dispatch-macro-character ## #! + (lambda (s c n) (shebang-reader s c n)) + *readtable*) + *readtable*)) + +(defun shebang-readtable () + *shebang-readtable*) + +(defun sbcl-package-p (package) + (let ((name (package-name package))) + (eql (mismatch "SB-" name) 3))) + +(defun sbcl-source-file-p (filename) + (loop for (_ pattern) in (logical-pathname-translations "SYS") + thereis (pathname-match-p filename pattern))) + +(defun guess-readtable-for-filename (filename) + (if (sbcl-source-file-p filename) + (shebang-readtable) + *readtable*)) + +(defvar *debootstrap-packages* t) + +(defun call-with-debootstrapping (fun) + (handler-bind ((sb-int:bootstrap-package-not-found + #'sb-int:debootstrap-package)) + (funcall fun))) + +(defmacro with-debootstrapping (&body body) + `(call-with-debootstrapping (lambda () ,@body))) + +(defimplementation call-with-syntax-hooks (fn) + (cond ((and *debootstrap-packages* + (sbcl-package-p *package*)) + (with-debootstrapping (funcall fn))) + (t + (funcall fn)))) + +(defimplementation default-readtable-alist () + (let ((readtable (shebang-readtable))) + (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages)) + collect (cons (package-name p) readtable)))) + +;;; Utilities + +(defimplementation arglist (fname) + (sb-introspect:function-arglist fname)) + +(defimplementation function-name (f) + (check-type f function) + (sb-impl::%fun-name f)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (flet ((ensure-list (thing) (if (listp thing) thing (list thing)))) + (let* ((flags (sb-cltl2:declaration-information decl-identifier))) + (if flags + ;; Symbols aren't printed with package qualifiers, but the FLAGS would + ;; have to be fully qualified when used inside a declaration. So we + ;; strip those as long as there's no better way. (FIXME) + `(&any ,@(remove-if-not #'(lambda (qualifier) + (find-symbol (symbol-name (first qualifier)) :cl)) + flags :key #'ensure-list)) + (call-next-method))))) + +(defvar *buffer-name* nil) +(defvar *buffer-offset*) +(defvar *buffer-substring* nil) + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning. +This traps all compiler conditions at a lower-level than using +C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to +craft our own error messages, which can omit a lot of redundant +information." + (let ((context (sb-c::find-error-context nil))) + (unless (eq condition *previous-compiler-condition*) + (setq *previous-compiler-condition* condition) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal (make-condition + 'compiler-condition + :original-condition condition + :severity (etypecase condition + (sb-c:compiler-error :error) + (sb-ext:compiler-note :note) + (style-warning :style-warning) + (warning :warning) + (error :error)) + :short-message (brief-compiler-message-for-emacs condition) + :references (condition-references (real-condition condition)) + :message (long-compiler-message-for-emacs condition context) + :location (compiler-note-location context)))) + +(defun real-condition (condition) + "Return the encapsulated condition or CONDITION itself." + (typecase condition + (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition)) + (t condition))) + +(defun condition-references (condition) + (if (typep condition 'sb-int:reference-condition) + (externalize-reference + (sb-int:reference-condition-references condition)))) + +(defun compiler-note-location (context) + (if context + (locate-compiler-note + (sb-c::compiler-error-context-file-name context) + (compiler-source-path context) + (sb-c::compiler-error-context-original-source context)) + (list :error "No error location available"))) + +(defun locate-compiler-note (file source-path source) + (cond ((and (not (eq file :lisp)) *buffer-name*) + ;; Compiling from a buffer + (let ((position (+ *buffer-offset* + (source-path-string-position + source-path *buffer-substring*)))) + (make-location (list :buffer *buffer-name*) + (list :position position)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (namestring file)) + (list :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 in compiler note ~S ~S ~S" file source-path source)))) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (let ((sb-int:*print-condition-references* nil)) + (princ-to-string condition))) + +(defun long-compiler-message-for-emacs (condition error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or sb-c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (sb-c::compiler-error-context-enclosing-source error-context) + (sb-c::compiler-error-context-source error-context))) + (let ((sb-int:*print-condition-references* nil)) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A" + enclosing source condition)))) + +(defun compiler-source-path (context) + "Return the source-path for the current compiler error. +Returns NIL if this cannot be determined by examining internal +compiler state." + (cond ((sb-c::node-p context) + (reverse + (sb-c::source-path-original-source + (sb-c::node-source-path context)))) + ((sb-c::compiler-error-context-p context) + (reverse + (sb-c::compiler-error-context-original-source-path context))))) + +(defimplementation call-with-compilation-hooks (function) + (declare (type function function)) + (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination) + (sb-c:compiler-error #'handle-notification-condition) + (sb-ext:compiler-note #'handle-notification-condition) + (style-warning #'handle-notification-condition) + (warning #'handle-notification-condition)) + (funcall function))) + +(defun handle-file-compiler-termination (condition) + "Handle a condition that caused the file compiler to terminate." + (handle-notification-condition + (sb-int:encapsulated-condition condition))) + +(defvar *trap-load-time-warnings* nil) + +(defimplementation swank-compile-file (filename load-p external-format) + (handler-case + (let ((output-file (with-compilation-hooks () + (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)) + (when load-p + (load output-file)))) + (sb-c:fatal-compiler-error () nil))) + +;;;; compile-string + +;;; We copy the string to a temporary file in order to get adequate +;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms +;;; which the previous approach using +;;; (compile nil `(lambda () ,(read-from-string string))) +;;; did not provide. + +(sb-alien:define-alien-routine "tmpnam" sb-alien:c-string + (dest (* sb-alien:c-string))) + +(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) + (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-directory directory + :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))))))) + +;;;; 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) + (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)))) + +(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 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-directory + emacs-string &allow-other-keys) + plist + (cond + (emacs-buffer + (let* ((*readtable* (guess-readtable-for-filename emacs-directory)) + (pos (if form-path + (with-debootstrapping + (source-path-string-position form-path emacs-string)) + character-offset)) + (snippet (string-path-snippet emacs-string form-path pos))) + (make-location `(:buffer ,emacs-buffer) + `(:position ,(+ pos emacs-position)) + `(:snippet ,snippet)))) + ((not pathname) + `(:error ,(format nil "Source of ~A ~A not found" + (string-downcase type) name))) + (t + (let* ((namestring (namestring (translate-logical-pathname pathname))) + (pos (source-file-position namestring file-write-date form-path + character-offset)) + (snippet (source-hint-snippet namestring file-write-date pos))) + (make-location `(:file ,namestring) + `(:position ,pos) + `(:snippet ,snippet)))))))) + +(defun string-path-snippet (string form-path position) + (if form-path + ;; If we have a form-path, use it to derive a more accurate + ;; snippet, so that we can point to the individual form rather + ;; than just the toplevel form. + (multiple-value-bind (data end) + (let ((*read-suppress* t)) + (read-from-string string nil nil :start position)) + (declare (ignore data)) + (subseq string position end)) + string)) + +(defun source-file-position (filename write-date form-path character-offset) + (let ((source (get-source-code filename write-date)) + (*readtable* (guess-readtable-for-filename filename))) + (1+ (with-debootstrapping + (if form-path + (source-path-string-position form-path source) + (or character-offset 0)))))) + +(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)))) + +(defun function-source-location (function &optional name) + (declare (type function 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) + (list :error (format nil "Error: ~A" e)))))) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (sb-int:info :variable :kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (sb-int:info :setf :inverse symbol) + (sb-int:info :setf :expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (sb-int:info :type :kind symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol type) + (case type + (:variable + (describe symbol)) + (:function + (describe (symbol-function symbol))) + (:setf + (describe (or (sb-int:info :setf :inverse symbol) + (sb-int:info :setf :expander symbol)))) + (:class + (describe (find-class symbol))) + (:type + (describe (sb-kernel:values-specifier-type symbol))))) + +#+#.(swank-backend::sbcl-with-xref-p) +(progn + (defmacro defxref (name) + `(defimplementation ,name (what) + (sanitize-xrefs + (mapcar #'source-location-for-xref-data + (,(find-symbol (symbol-name name) "SB-INTROSPECT") + what))))) + (defxref who-calls) + (defxref who-binds) + (defxref who-sets) + (defxref who-references) + (defxref who-macroexpands)) + +(defun source-location-for-xref-data (xref-data) + (let ((name (car xref-data)) + (source-location (cdr xref-data))) + (list name + (handler-case (make-definition-source-location source-location + 'function + name) + (error (e) + (list :error (format nil "Error: ~A" e))))))) + +(defimplementation list-callers (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))) + +(defimplementation list-callees (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))) + +(defun sanitize-xrefs (xrefs) + (remove-duplicates + (remove-if (lambda (f) + (member f (ignored-xref-function-names))) + (loop for entry in xrefs + for name = (car entry) + collect (if (and (consp name) + (member (car name) + '(sb-pcl::fast-method + sb-pcl::slow-method + sb-pcl::method))) + (cons (cons 'defmethod (cdr name)) + (cdr entry)) + entry)) + :key #'car) + :test (lambda (a b) + (and (eq (first a) (first b)) + (equal (second a) (second b)))))) + +(defun ignored-xref-function-names () + #-#.(swank-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)." + (let ((name (sb-kernel:%fun-name fn))) + (list name (safe-function-source-location fn name)))) + +;;; macroexpansion + +(defimplementation macroexpand-all (form) + (let ((sb-walker:*walk-form-expand-macros-p* t)) + (sb-walker:walk-form form))) + + +;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation install-debugger-globally (function) + (setq sb-ext:*invoke-debugger-hook* function)) + +(defimplementation condition-extras (condition) + (cond #+#.(swank-backend::sbcl-with-new-stepper-p) + ((typep condition 'sb-impl::step-form-condition) + `((:show-frame-source 0))) + ((typep condition 'sb-int:reference-condition) + (let ((refs (sb-int:reference-condition-references condition))) + (if refs + `((:references ,(externalize-reference refs)))))))) + +(defun externalize-reference (ref) + (etypecase ref + (null nil) + (cons (cons (externalize-reference (car ref)) + (externalize-reference (cdr ref)))) + ((or string number) ref) + (symbol + (cond ((eq (symbol-package ref) (symbol-package :test)) + ref) + (t (symbol-name ref)))))) + +(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 + (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) + #+#.(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)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + "Return a list of frames starting with frame number START and +continuing to frame number END or, if END is nil, the last frame on the +stack." + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (sb-di:frame-down f) + for i from start below end + while f + collect f))) + +(defimplementation print-frame (frame stream) + (sb-debug::print-frame-call frame stream)) + +;;;; Code-location -> source-location translation + +;;; If debug-block info is avaibale, we determine the file position of +;;; the source-path for a code-location. If the code was compiled +;;; with C-c C-c, we have to search the position in the source string. +;;; If there's no debug-block info, we return the (less precise) +;;; source-location of the corresponding function. + +(defun code-location-source-location (code-location) + (let* ((dsource (sb-di:code-location-debug-source code-location)) + (plist (sb-c::debug-source-plist dsource))) + (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) + (if (code-location-has-debug-block-info-p code-location) + (source-file-source-location code-location) + (fallback-source-location code-location))) + +(defun fallback-source-location (code-location) + (let ((fun (code-location-debug-fun-fun code-location))) + (cond (fun (function-source-location fun)) + (t (error "Cannot find source location for: ~A " code-location))))) + +(defun lisp-source-location (code-location) + (let ((source (prin1-to-string + (sb-debug::code-location-source-form code-location 100)))) + (make-location `(:source-form ,source) '(:position 0)))) + +(defun emacs-buffer-source-location (code-location plist) + (if (code-location-has-debug-block-info-p code-location) + (destructuring-bind (&key emacs-buffer emacs-position emacs-string + &allow-other-keys) + plist + (let* ((pos (string-source-position code-location emacs-string)) + (snipped (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)) + (filename (code-location-debug-source-name code-location)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (let* ((pos (stream-source-position code-location s)) + (snippet (read-snippet s pos))) + (make-location `(:file ,filename) + `(:position ,(1+ pos)) + `(:snippet ,snippet)))))) + +(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-di::code-location-debug-source code-location))) + +(defun code-location-debug-fun-fun (code-location) + (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location))) + +(defun code-location-has-debug-block-info-p (code-location) + (handler-case + (progn (sb-di:code-location-debug-block code-location) + t) + (sb-di:no-debug-blocks () nil))) + +(defun stream-source-position (code-location stream) + (let* ((cloc (sb-debug::maybe-block-start-location code-location)) + (tlf-number (sb-di::code-location-toplevel-form-offset cloc)) + (form-number (sb-di::code-location-form-number cloc))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +(defun string-source-position (code-location string) + (with-input-from-string (s string) + (stream-source-position code-location s))) + +;;; source-path-file-position and friends are in swank-source-path-parser + +(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 + (sb-di:frame-code-location (nth-frame index)))) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))) + +(defun debug-var-value (var frame location) + (ecase (sb-di:debug-var-validity var location) + (:valid (sb-di:debug-var-value var frame)) + ((:invalid :unknown) ':<not-available>))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (sb-di:frame-code-location frame)) + (vars (frame-debug-vars frame))) + (loop for v across vars collect + (list :name (sb-di:debug-var-symbol v) + :id (sb-di:debug-var-id v) + :value (debug-var-value v frame loc))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame (sb-di:frame-code-location frame)))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (sb-di:frame-catches (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (let ((frame (nth-frame index))) + (funcall (the function + (sb-di:preprocess-for-eval form + (sb-di:frame-code-location frame))) + frame))) + +#+#.(swank-backend::sbcl-with-restart-frame) +(progn + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index))) + (cond ((sb-debug:frame-has-debug-tag-p frame) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (sb-debug:unwind-to-frame-and-call frame + (lambda () + (values-list values))))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let* ((frame (nth-frame index))) + (cond ((sb-debug:frame-has-debug-tag-p frame) + (let* ((call-list (sb-debug::frame-call-as-list frame)) + (fun (fdefinition (car call-list))) + (thunk (lambda () + ;; Ensure that the thunk gets tail-call-optimized + (declare (optimize (debug 1))) + (apply fun (cdr call-list))))) + (sb-debug:unwind-to-frame-and-call frame thunk))) + (t (format nil "Cannot restart frame: ~S" frame)))))) + +;; FIXME: this implementation doesn't unwind the stack before +;; re-invoking the function, but it's better than no implementation at +;; all. +#-#.(swank-backend::sbcl-with-restart-frame) +(progn + (defun sb-debug-catch-tag-p (tag) + (and (symbolp tag) + (not (symbol-package tag)) + (string= tag :sb-debug-catch-tag))) + + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index)) + (probe (assoc-if #'sb-debug-catch-tag-p + (sb-di::frame-catches frame)))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (return-from-frame index (sb-debug::frame-call-as-list frame))))) + +;;;;; reference-conditions + +(defimplementation format-sldb-condition (condition) + (let ((sb-int:*print-condition-references* nil)) + (princ-to-string condition))) + + +;;;; Profiling + +(defimplementation profile (fname) + (when fname (eval `(sb-profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(sb-profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (sb-profile:unprofile) + "All functions unprofiled.") + +(defimplementation profile-report () + (sb-profile:report)) + +(defimplementation profile-reset () + (sb-profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (sb-profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(sb-profile:profile ,(package-name (find-package package))))) + + +;;;; Inspector + +(defclass sbcl-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'sbcl-inspector)) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (declare (ignore inspector)) + (cond ((sb-di::indirect-value-cell-p o) + (values "A value cell." (label-value-line* + (:value (sb-kernel:value-cell-ref o))))) + (t + (multiple-value-bind (text label parts) (sb-impl::inspected-parts o) + (if label + (values text (loop for (l . v) in parts + append (label-value-line l v))) + (values text (loop for value in parts for i from 0 + append (label-value-line i value)))))))) + +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) + (declare (ignore inspector)) + (let ((header (sb-kernel:widetag-of o))) + (cond ((= header sb-vm:simple-fun-header-widetag) + (values "A simple-fun." + (label-value-line* + (:name (sb-kernel:%simple-fun-name o)) + (:arglist (sb-kernel:%simple-fun-arglist o)) + (:self (sb-kernel:%simple-fun-self o)) + (:next (sb-kernel:%simple-fun-next o)) + (:type (sb-kernel:%simple-fun-type o)) + (:code (sb-kernel:fun-code-header o))))) + ((= header sb-vm:closure-header-widetag) + (values "A closure." + (append + (label-value-line :function (sb-kernel:%closure-fun o)) + `("Closed over values:" (:newline)) + (loop for i below (1- (sb-kernel:get-closure-length o)) + append (label-value-line + i (sb-kernel:%closure-index-ref o i)))))) + (t (call-next-method o))))) + +(defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ backend-inspector)) + (declare (ignore _)) + (values (format nil "~A is a code data-block." o) + (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 + o sb-vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (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) + , (with-output-to-string (s) + (cond ((sb-kernel:%code-debug-info o) + (sb-disassem:disassemble-code-component o :stream s)) + (t + (sb-disassem:disassemble-memory + (sb-disassem::align + (+ (logandc2 (sb-kernel:get-lisp-obj-address o) + sb-vm:lowtag-mask) + (* sb-vm:code-constants-offset + sb-vm:n-word-bytes)) + (ash 1 sb-vm:n-lowtag-bits)) + (ash (sb-kernel:%code-code-size o) sb-vm:word-shift) + :stream s)))))))) + +(defmethod inspect-for-emacs ((o sb-ext:weak-pointer) (inspector backend-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 backend-inspector)) + (declare (ignore inspector)) + (values "A fdefn object." + (label-value-line* + (:name (sb-kernel:fdefn-name o)) + (:function (sb-kernel:fdefn-fun o))))) + +(defmethod inspect-for-emacs :around ((o generic-function) + (inspector backend-inspector)) + (declare (ignore inspector)) + (multiple-value-bind (title contents) (call-next-method) + (values title + (append + contents + (label-value-line* + (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o)) + (:initial-methods (sb-pcl::generic-function-initial-methods o)) + ))))) + + +;;;; Multiprocessing + +#+(and sb-thread + #.(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) + (sb-thread:make-thread fn :name name)) + + (defimplementation thread-id (thread) + (block thread-id + (sb-thread:with-mutex (*thread-id-map-lock*) + (loop for id being the hash-key in *thread-id-map* + using (hash-value thread-pointer) + do + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (cond ((null maybe-thread) + ;; the value is gc'd, remove it manually + (remhash id *thread-id-map*)) + ((eq thread maybe-thread) + (return-from thread-id id))))) + ;; lazy numbering + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread)) + id)))) + + (defimplementation find-thread (id) + (sb-thread:with-mutex (*thread-id-map-lock*) + (let ((thread-pointer (gethash id *thread-id-map*))) + (if thread-pointer + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (if maybe-thread + maybe-thread + ;; the value is gc'd, remove it manually + (progn + (remhash id *thread-id-map*) + nil))) + nil)))) + + (defimplementation thread-name (thread) + ;; sometimes the name is not a string (e.g. NIL) + (princ-to-string (sb-thread:thread-name thread))) + + (defimplementation thread-status (thread) + (if (sb-thread:thread-alive-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (sb-thread:make-mutex :name name)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (sb-thread:with-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*) + + (defimplementation all-threads () + (sb-thread:list-all-threads)) + + (defimplementation interrupt-thread (thread fn) + (sb-thread:interrupt-thread thread fn)) + + (defimplementation kill-thread (thread) + (sb-thread:terminate-thread thread)) + + (defimplementation thread-alive-p (thread) + (sb-thread:thread-alive-p thread)) + + (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (sb-thread:make-mutex)) + (waitqueue (sb-thread:make-waitqueue)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (sb-thread:with-mutex (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-mutex (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation receive () + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-mutex (mutex) + (loop + (let ((q (mailbox.queue mbox))) + (cond (q (return (pop (mailbox.queue mbox)))) + (t (sb-thread:condition-wait (mailbox.waitqueue mbox) + mutex)))))))) + + + ;; Auto-flush streams + + (defvar *auto-flush-interval* 0.15 + "How often to flush interactive streams. This valu is passed + directly to cl:sleep.") + + (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush")) + + (defvar *auto-flush-thread* nil) + + (defvar *auto-flush-streams* '()) + + (defimplementation make-stream-interactive (stream) + (call-with-recursive-lock-held + *auto-flush-lock* + (lambda () + (pushnew 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 + (call-with-recursive-lock-held + *auto-flush-lock* + (lambda () + (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 *auto-flush-interval*))) + + ) + +(defimplementation quit-lisp () + #+sb-thread + (dolist (thread (remove (current-thread) (all-threads))) + (ignore-errors (sb-thread:interrupt-thread + thread (lambda () (sb-ext:quit :recklessly-p t))))) + (sb-ext:quit)) + + + +;;Trace implementations +;;In SBCL, we have: +;; (trace <name>) +;; (trace :methods '<name>) ;to trace all methods of the gf <name> +;; (trace (method <name> <qualifier>? (<specializer>+))) +;; <name> can be a normal name or a (setf name) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((member fspec (eval '(trace)) :test #'equal) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args)) + (format nil "~S is now traced." fspec)))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defmethod) + (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec))))) + ((:defgeneric) + (toggle-trace-aux (second spec) :methods t)) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee :wherein (list (process-fspec caller))))))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + #+#.(swank-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)) + +(defimplementation hash-table-weakness (hashtable) + #+#.(swank-backend::sbcl-with-weak-hash-tables) + (sb-ext:hash-table-weakness hashtable))
Added: branches/trunk-reorg/thirdparty/slime/swank-scl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-scl.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-scl.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,2070 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; Scieneer Common Lisp code for SLIME. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package :swank-backend) + + + +;;; swank-mop + +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) + +(defun swank-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; TCP server +;;; +;;; SCL only supports the :spawn communication style. +;;; + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port) + (let ((addr (resolve-hostname host))) + (ext:create-inet-listener port :stream :host addr :reuse-address t))) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (ext:close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (let ((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) + "Return the file descriptor for the socket represented by 'socket." + (etypecase socket + (fixnum socket) + (stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of 'hostname as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd external-format buffering) + "Create a new input/output fd-stream for 'fd." + (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 + +(defclass slime-input-stream (ext:character-input-stream) + ((buffer :initarg :buffer :type string) + (index :initarg :index :initform 0 :type fixnum) + (position :initarg :position :initform 0 :type integer) + (interactive :initarg :interactive :initform nil :type (member nil t)) + (output-stream :initarg :output-stream :initform nil) + (input-fn :initarg :input-fn :type function) + )) + +(defun make-slime-input-stream (input-fn &optional output-stream) + (declare (function input-fn)) + (make-instance 'slime-input-stream + :in-buffer (make-string 256) + :in-head 0 :in-tail 0 + :out-buffer "" + :buffer "" :index 0 + :input-fn input-fn + :output-stream output-stream)) + +(defmethod print-object ((s slime-input-stream) stream) + (print-unreadable-object (s stream :type t))) + +;;; input-stream-p inherits from input-stream. +;;; output-stream-p inherits nil. + +(defmethod ext:stream-listen ((stream slime-input-stream)) + (let* ((buffer (slot-value stream 'buffer)) + (index (slot-value stream 'index)) + (length (length buffer))) + (declare (type string buffer) + (fixnum index length)) + (< index length))) + +(defmethod close ((stream slime-input-stream) &key ((:abort abort) nil)) + (declare (ignore abort)) + (when (ext:stream-open-p stream) + (setf (ext:stream-open-p stream) nil) + (setf (ext:stream-in-buffer stream) " ") + t)) + +(defmethod ext:stream-clear-input ((stream slime-input-stream)) + (let* ((input-buffer (slot-value stream 'buffer)) + (index (slot-value stream 'index)) + (input-length (length input-buffer)) + (available (- input-length index)) + (position (slot-value stream 'position)) + (new-position (+ position available))) + (declare (type kernel:index index available position new-position)) + (setf (slot-value stream 'position) new-position)) + (setf (slot-value stream 'buffer) "") + (setf (slot-value stream 'index) 0) + nil) + +;;; No 'stream-finish-output method. +;;; No 'stream-force-output method. +;;; No 'stream-clear-output method. + +;;; stream-element-type inherits from character-stream. + +;;; No 'stream-line-length method. +;;; No 'stream-line-column method. + +;;; Add the remaining input to the current position. +(defmethod file-length ((stream slime-input-stream)) + (let* ((input-buffer (slot-value stream 'buffer)) + (index (slot-value stream 'index)) + (input-length (length input-buffer)) + (available (- input-length index)) + (position (slot-value stream 'position)) + (file-length (+ position available))) + (declare (type kernel:index index available position file-length)) + file-length)) + +(defmethod ext:stream-file-position ((stream slime-input-stream) + &optional position) + (let ((current-position (slot-value stream 'position))) + (declare (type kernel:index current-position)) + (cond (position + ;; Could make an attempt here, but just give up for now. + nil) + (t + current-position)))) + +(defmethod interactive-stream-p ((stream slime-input-stream)) + (slot-value stream 'interactive)) + +;;; No 'file-string-length method. + +(defmethod ext:stream-read-chars ((stream slime-input-stream) buffer + start requested waitp) + (declare (type simple-string buffer) + (type kernel:index start requested)) + (let* ((input-buffer (slot-value stream 'buffer)) + (index (slot-value stream 'index)) + (input-length (length input-buffer)) + (available (- input-length index)) + (copy (min available requested))) + (declare (string input-buffer) + (type kernel:index index available copy)) + (cond ((plusp copy) + (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 + (let ((output-stream (slot-value stream 'output-stream)) + (input-fn (slot-value stream 'input-fn))) + (declare (type function input-fn)) + (when output-stream + (force-output output-stream)) + (let ((new-input (funcall input-fn))) + (cond ((zerop (length new-input)) + -1) + (t + (setf (slot-value stream 'buffer) new-input) + (setf (slot-value stream 'index) 0) + (ext:stream-read-chars stream buffer + start requested waitp)))))) + (t + 0)))) + +;;; Slime output stream. + +(defclass slime-output-stream (ext:character-output-stream) + ((output-fn :initarg :output-fn :type function) + (column :initform 0 :type kernel:index) + (interactive :initform nil :type (member nil t)) + (position :initform 0 :type integer))) + +(defun make-slime-output-stream (output-fn) + (declare (function output-fn)) + (make-instance 'slime-output-stream + :in-buffer "" + :out-buffer (make-string 256) + :output-fn output-fn)) + +(defmethod print-object ((s slime-output-stream) stream) + (print-unreadable-object (s stream :type t))) + +;;; Use default 'input-stream-p method for 'output-stream which returns 'nil. +;;; Use default 'output-stream-p method for 'output-stream which returns 't. + +;;; No 'stream-listen method. + +(defmethod close ((stream slime-output-stream) &key ((:abort abort) nil)) + (when (ext:stream-open-p stream) + (unless abort + (finish-output stream)) + (setf (ext:stream-open-p stream) nil) + (setf (ext:stream-out-buffer stream) " ") + t)) + +;;; No 'stream-clear-input method. + +(defmethod ext:stream-finish-output ((stream slime-output-stream)) + nil) + +(defmethod ext:stream-force-output ((stream slime-output-stream)) + nil) + +(defmethod ext:stream-clear-output ((stream slime-output-stream)) + nil) + +;;; Use default 'stream-element-type method for 'character-stream which +;;; returns 'base-char. + +(defmethod ext:stream-line-length ((stream slime-output-stream)) + 80) + +(defmethod ext:stream-line-column ((stream slime-output-stream)) + (slot-value stream 'column)) + +(defmethod file-length ((stream slime-output-stream)) + (slot-value stream 'position)) + +(defmethod ext:stream-file-position ((stream slime-output-stream) + &optional position) + (declare (optimize (speed 3))) + (cond (position + (let* ((current-position (slot-value stream 'position)) + (target-position (etypecase position + ((member :start) 0) + ((member :end) current-position) + (kernel:index position)))) + (declare (type kernel:index current-position target-position)) + (cond ((= target-position current-position) + t) + ((> target-position current-position) + (let ((output-fn (slot-value stream 'output-fn)) + (fill-size (- target-position current-position))) + (declare (function output-fn)) + (funcall output-fn (make-string fill-size + :initial-element #\space)) + (setf (slot-value stream 'position) target-position)) + t) + (t + nil)))) + (t + (slot-value stream 'position)))) + +(defmethod interactive-stream-p ((stream slime-output-stream)) + (slot-value stream 'interactive)) + +;;; Use the default 'character-output-stream 'file-string-length method. + +;;; stream-write-chars +;;; +;;; The stream out-buffer is typically large enough that there is little point +;;; growing the stream output 'string large than the total size. For typical +;;; 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 waitp) + (declare (simple-string string) + (type kernel:index start end) + (ignore waitp)) + (declare (optimize (speed 3))) + (unless (ext:stream-open-p stream) + (error 'kernel:simple-stream-error + :stream stream + :format-control "Stream closed.")) + (let* ((string-length (length string)) + (start (cond ((< start 0) 0) + ((> start string-length) string-length) + (t start))) + (end (cond ((< end start) start) + ((> end string-length) string-length) + (t end))) + (length (- end start)) + (output-fn (slot-value stream 'output-fn))) + (declare (type kernel:index start end length) + (type function output-fn)) + (unless (zerop length) + (funcall output-fn (subseq string start end)) + (let ((last-newline (position #\newline string :from-end t + :start start :end end))) + (setf (slot-value stream 'column) + (if last-newline + (- end last-newline 1) + (let ((column (slot-value stream 'column))) + (declare (type kernel:index column)) + (+ column (- end start)))))))) + (- end start)) + +;;; + +(defimplementation make-fn-streams (input-fn output-fn) + (let* ((output (make-slime-output-stream output-fn)) + (input (make-slime-input-stream input-fn output))) + (values input output))) + +(defimplementation make-stream-interactive (stream) + (when (or (typep stream 'slime-input-stream) + (typep stream 'slime-output-stream)) + (setf (slot-value stream 'interactive) t))) + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. + Nil if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation swank-compile-file (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)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string)) + (with-input-from-string (stream string) + (ext:compile-from-stream + stream + :source-info `(:emacs-buffer ,buffer + :emacs-buffer-offset ,position + :emacs-buffer-string ,string)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `swank:compiler-condition's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal (make-condition + 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :short-message (brief-compiler-message-for-emacs condition) + :message (long-compiler-message-for-emacs condition context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context))))) + +(defun severity-for-emacs (condition) + "Return the severity of 'condition." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. + When Emacs presents the message it already has the source popped up + and the source form highlighted. This makes much of the information in + the error-context redundant." + (princ-to-string condition)) + +(defun long-compiler-message-for-emacs (condition error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A" + enclosing source condition))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :position (+ *buffer-start-position* pos)))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. + Return a `location' record, or (:error <reason>) on failure." + (if (null context) + (note-error-location) + (let ((file (c::compiler-error-context-file-name context)) + (source (c::compiler-error-context-original-source context)) + (path + (reverse (c::compiler-error-context-original-source-path context)))) + (or (locate-compiler-note file source path) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (list :error "No error location available.")) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (let ((position (+ *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + (make-location (list :buffer *buffer-name*) + (list :position position)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position + (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + + +;;; TODO +(defimplementation who-calls (name) nil) +(defimplementation who-references (name) nil) +(defimplementation who-binds (name) nil) +(defimplementation who-sets (name) nil) +(defimplementation who-specializes (symbol) nil) +(defimplementation who-macroexpands (name) nil) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(declaim (inline map-code-constants)) +(defun map-code-constants (code fn) + "Call 'fn for each constant in 'code's constant pool." + (check-type code kernel:code-component) + (loop for i from vm:code-constants-offset below (kernel:get-header-data code) + do (funcall fn (kernel:code-header-ref code i)))) + +(defun function-callees (function) + "Return 'function's callees as a list of functions." + (let ((callees '())) + (map-code-constants + (vm::find-code-object function) + (lambda (obj) + (when (kernel:fdefn-p obj) + (push (kernel:fdefn-function obj) callees)))) + callees)) + +(declaim (ext:maybe-inline map-allocated-code-components)) +(defun map-allocated-code-components (spaces fn) + "Call FN for each allocated code component in one of 'spaces. FN + receives the object as argument. 'spaces should be a list of the + symbols :dynamic, :static, or :read-only." + (dolist (space spaces) + (declare (inline vm::map-allocated-objects) + (optimize (ext:inhibit-warnings 3))) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum size) (ignore size)) + (when (= vm:code-header-type header) + (funcall fn obj))) + space))) + +(declaim (ext:maybe-inline map-caller-code-components)) +(defun map-caller-code-components (function spaces fn) + "Call 'fn for each code component with a fdefn for 'function in its + constant pool." + (let ((function (coerce function 'function))) + (declare (inline map-allocated-code-components)) + (map-allocated-code-components + spaces + (lambda (obj) + (map-code-constants + obj + (lambda (constant) + (when (and (kernel:fdefn-p constant) + (eq (kernel:fdefn-function constant) + function)) + (funcall fn obj)))))))) + +(defun function-callers (function &optional (spaces '(:read-only :static + :dynamic))) + "Return 'function's callers. The result is a list of code-objects." + (let ((referrers '())) + (declare (inline map-caller-code-components)) + (map-caller-code-components function spaces + (lambda (code) (push code referrers))) + referrers)) + +(defun debug-info-definitions (debug-info) + "Return the defintions for a debug-info. This should only be used + for code-object without entry points, i.e., byte compiled + code (are theree others?)" + ;; This mess has only been tested with #'ext::skip-whitespace, a + ;; byte-compiled caller of #'read-char . + (check-type debug-info (and (not c::compiled-debug-info) c::debug-info)) + (let ((name (c::debug-info-name debug-info)) + (source (c::debug-info-source debug-info))) + (destructuring-bind (first) source + (ecase (c::debug-source-from first) + (:file + (list (list name + (make-location + (list :file (unix-truename (c::debug-source-name first))) + (list :function-name (string name)))))))))) + +(defun valid-function-name-p (name) + (or (symbolp name) (and (consp name) + (eq (car name) 'setf) + (symbolp (cadr name)) + (not (cddr name))))) + +(defun code-component-entry-points (code) + "Return a list ((name location) ...) of function definitons for + the code omponent 'code." + (let ((names '())) + (do ((f (kernel:%code-entry-points code) (kernel::%function-next f))) + ((not f)) + (let ((name (kernel:%function-name f))) + (when (valid-function-name-p name) + (push (list name (function-location f)) names)))) + names)) + +(defimplementation list-callers (symbol) + "Return a list ((name location) ...) of callers." + (let ((components (function-callers symbol)) + (xrefs '())) + (dolist (code components) + (let* ((entry (kernel:%code-entry-points code)) + (defs (if entry + (code-component-entry-points code) + ;; byte compiled stuff + (debug-info-definitions + (kernel:%code-debug-info code))))) + (setq xrefs (nconc defs xrefs)))) + xrefs)) + +(defimplementation list-callees (symbol) + (let ((fns (function-callees symbol))) + (mapcar (lambda (fn) + (list (kernel:%function-name fn) + (function-location fn))) + fns))) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the SCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `swank-source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. + This is useful when debugging the definition-finding code.") + +(defvar *source-snippet-size* 256 + "Maximum number of characters in a snippet of source code. + Snippets at the beginning of definitions are used to tell Emacs what + the definitions looks like, so that it can accurately find them by + text search.") + +(defmacro safe-definition-finding (&body body) + "Execute 'body and return the source-location it returns. + If an error occurs and `*debug-definition-finding*' is false, then + return an error pseudo-location. + + The second return value is 'nil if no error occurs, otherwise it is the + condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values (list :error (princ-to-string c)) c)))))) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for 'code-location." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for 'code-location in 'filename." + (let* ((code-date (di:debug-source-created debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a 'code-location from a stream. + This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLIME stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :position (+ (getf info :emacs-buffer-offset) position)) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for 'debug-info. + Function-name source-locations are a fallback for when precise + positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of 'debug-source contain an Emacs buffer location? + This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream) + "Return the byte offset of 'code-location in 'stream. Extract the + toplevel-form-number and form-number from 'code-location and use that + to find the position of the corresponding form. + + Finish with 'stream positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (di:code-location-top-level-form-offset location)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in 'stream. + 'tlf-number is the top-level-form number. + 'form-number is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of 'code-location in 'string. + See 'code-location-stream-position." + (with-input-from-string (s string) + (code-location-stream-position code-location s))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name))) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; SCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the SCL manual for more details. + +(defun function-definitions (name) + "Return definitions for 'name in the "function namespace", i.e., + regular functions, generic functions, methods and macros. + 'name can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (special? (and (symbolp name) (special-operator-p name))) + (function? (and (valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (special? + (list `((:special-operator ,name) + (:error ,(format nil "Special operator: ~S" name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (generic-function-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for 'function." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + + +(defun byte-function-location (fn) + "Return the location of the byte-compiled function 'fn." + (etypecase fn + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((component (c::byte-function-component fn)) + (debug-info (kernel:%code-debug-info component))) + (debug-info-function-name-location debug-info))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fn))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in SCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is 'function a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that 'function belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + ;; Find the location in a constructor. + (function-location (struct-constructor dd))) + +(defun struct-constructor (dd) + "Return a constructor function from a defstruct definition. +Signal an error if no constructor can be found." + (let ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (when (or (null constructor) + (and (consp constructor) (null (car constructor)))) + (error "Cannot find structure's constructor: ~S" + (kernel::dd-name dd))) + (coerce (if (consp constructor) (first constructor) constructor) + 'function))) + +;;;;;; Generic functions and methods + +(defun generic-function-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (clos:generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (clos:generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable "definition specifier" for METHOD." + (let* ((gf (clos:method-generic-function method)) + (name (clos:generic-function-name gf)) + (specializers (clos:method-specializers method)) + (qualifiers (clos:method-qualifiers method))) + `(method ,name ,@qualifiers ,specializers #+nil (clos::unparse-specializers specializers)))) + +;; XXX maybe special case setters/getters +(defun method-location (method) + (function-location (clos:method-function method))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (find-class name nil))) + (etypecase class + (null '()) + (structure-class + (list (list `(defstruct ,name) + (dd-location (find-dd name))))) + (standard-class + (list (list `(defclass ,name) + (class-location (find-class name))))) + ((or built-in-class + kernel:funcallable-structure-class) + (list (list `(kernel::define-type-class ,name) + `(:error + ,(format nil "No source info for ~A" name))))))))) + +(defun class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (class-name class))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((name (class-name class))) + `(:error ,(format nil "No location info for condition: ~A" name)))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun definition-source-location (object name) + `(:error ,(format nil "No source info for: ~A" object))) + +(defun setf-definitions (name) + (let ((function (or (ext:info :setf :inverse name) + (ext:info :setf :expander name)))) + (if function + (list (list `(setf ,name) + (function-location (coerce function 'function))))))) + + +(defun variable-location (symbol) + `(:error ,(format nil "No source info for variable ~S" symbol))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(c::vop ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unknown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (etypecase fun + (function (function-arglist fun)) + (symbol (function-arglist (or (macro-function fun) + (symbol-function fun)))))) + +(defun function-arglist (fun) + (flet ((compiled-function-arglist (x) + (let ((args (kernel:%function-arglist x))) + (if args + (read-arglist x) + :not-available)))) + (case (kernel:get-type fun) + (#.vm:closure-header-type + (compiled-function-arglist + (kernel:%closure-function fun))) + ((#.vm:function-header-type #.vm:closure-function-header-type) + (compiled-function-arglist fun)) + (#.vm:funcallable-instance-header-type + (typecase fun + (kernel:byte-function + :not-available) + (kernel:byte-closure + :not-available) + (eval:interpreted-function + (eval:interpreted-function-arglist fun)) + (otherwise + (clos::generic-function-lambda-list fun)))) + (t + :non-available)))) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((typep function 'generic-function) + (clos:generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + +;;; A simple case: the arglist is available as a string that we can +;;; `read'. + +(defun read-arglist (fn) + "Parse the arglist-string of the function object FN." + (let ((string (kernel:%function-arglist + (kernel:%function-self fn))) + (package (find-package + (c::compiled-debug-info-package + (kernel:%code-debug-info + (vm::find-code-object fn)))))) + (with-standard-io-syntax + (let ((*package* (or package *package*))) + (read-from-string string))))) + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. + A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + +;;; Deriving arglists for byte-compiled functions: +;;; +(defun byte-code-function-arglist (fn) + ;; There doesn't seem to be much arglist information around for + ;; byte-code functions. Use the arg-count and return something like + ;; (arg0 arg1 ...) + (etypecase fn + (c::simple-byte-function + (loop for i from 0 below (c::simple-byte-function-num-args fn) + collect (make-arg-symbol i))) + (c::hairy-byte-function + (hairy-byte-function-arglist fn)) + (c::byte-closure + (byte-code-function-arglist (c::byte-closure-function fn))))) + +(defun make-arg-symbol (i) + (make-symbol (format nil "~A~D" (string 'arg) i))) + +;;; A "hairy" byte-function is one that takes a variable number of +;;; arguments. `hairy-byte-function' is a type from the bytecode +;;; interpreter. +;;; +(defun hairy-byte-function-arglist (fn) + (let ((counter -1)) + (flet ((next-arg () (make-arg-symbol (incf counter)))) + (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p + keywords-p keywords) fn + (let ((arglist '()) + (optional (- max-args min-args))) + ;; XXX isn't there a better way to write this? + ;; (Looks fine to me. -luke) + (dotimes (i min-args) + (push (next-arg) arglist)) + (when (plusp optional) + (push '&optional arglist) + (dotimes (i optional) + (push (next-arg) arglist))) + (when rest-arg-p + (push '&rest arglist) + (push (next-arg) arglist)) + (when keywords-p + (push '&key arglist) + (loop for (key _ __) in keywords + do (push key arglist)) + (when (eq keywords-p :allow-others) + (push '&allow-other-keys arglist))) + (nreverse arglist)))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form) + (macroexpand form)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation call-without-interrupts (fn) + (funcall fn)) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + (if (eq ext:*case-mode* :upper) "scl" "scl-lower")) + +(defimplementation quit-lisp () + (ext:quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; swank-source-path-parser + + +;;;; Debugging + +(defvar *sldb-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error (make-condition + 'sldb-condition + :original-condition condition))))) + (funcall debugger-loop-fn)))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sldb-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f + collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location-for-emacs (index) + (code-location-source-location (di:frame-code-location (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (di::debug-function-debug-variables (di:frame-debug-function frame))) + +(defun debug-var-value (var frame location) + (let ((validity (di:debug-variable-validity var location))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (di:frame-code-location frame)) + (vars (frame-debug-vars frame))) + (loop for v across vars collect + (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame loc))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame (di:frame-code-location frame)))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of SCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sldb-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:ucontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:ucontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; SCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<<known-return convention not supported>>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol (symbol-name '#:function-end-breakpoint-values/standard) + :debug-internals))) + (cond (sym (funcall sym sigcontext)) + (t (di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +#+nil +(defimplementation condition-extras ((c breakpoint)) + ;; simply pop up the source buffer + `((:short-frame-source 0))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +#+nil +(defimplementation sldb-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + ((or di::bogus-debug-function di::interpreted-debug-function) + -1))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +CSP = ~X +CFP = ~X +IP = ~X +OCFP = ~X +LRA = ~X~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + + +(defimplementation disassemble-frame (frame-number) + "Return a string with the disassembly of frames code." + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (format t "~%[Disassembling bogus frames not implemented]"))))) + + +;;;; Inspecting + +(defclass scl-inspector (backend-inspector) ()) + +(defimplementation make-default-inspector () + (make-instance 'scl-inspector)) + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:instance-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:function-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp (symbol-name '#:-type) (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list (symbol-name '#:-type) :vm) + (apropos-list (symbol-name '#:-type) :bignum)))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + (cond ((di::indirect-value-cell-p o) + (values (format nil "~A is a value cell." o) + `("Value: " (:value ,(c:value-cell-ref o))))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (scl-inspect o)))) + +(defun scl-inspect (o) + (destructuring-bind (text labeledp . parts) + (inspect::describe-parts o) + (values (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) + (declare (ignore inspector)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (values (format nil "~A is a function." o) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s)))))) + ((= header vm:closure-header-type) + (values (format nil "~A is a closure" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (- (kernel:get-closure-length o) + (1- vm:closure-info-offset)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (scl-inspect o)) + (t + (call-next-method))))) + + +(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector)) + (declare (ignore _)) + (values (format nil "~A is a code data-block." o) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((kernel:%code-debug-info o) + (disassem:disassemble-code-component o :stream s)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift) + :stream s)))))))) + +(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector)) + (declare (ignore inspector)) + (values (format nil "~A is a fdenf object." o) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) + +(defmethod inspect-for-emacs ((o array) (inspector backend-inspector)) + inspector + (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 simple-vector) (inspector backend-inspector)) + inspector + (values (format nil "~A is a vector." o) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (unless (eq (array-element-type o) 'nil) + (loop for i below (length o) + append (label-value-line i (aref o i))))))) + +(defun inspect-alien-record (alien) + (values + (format nil "~A is an alien value." alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (label-value-line slot (alien:slot alien slot))))))))) + +(defun inspect-alien-pointer (alien) + (values + (format nil "~A is an alien value." alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien)))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (scl-inspect alien)))) + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + #+nil :methods #+nil methods)) + + +;;;; Multiprocessing + +(defimplementation spawn (fn &key name) + (thread:thread-create fn :name (or name "Anonymous"))) + +(defvar *thread-id-counter* 0) +(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter")) + +(defimplementation thread-id (thread) + (thread:with-lock-held (*thread-id-counter-lock*) + (or (getf (thread:thread-plist thread) 'id) + (setf (getf (thread:thread-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (block find-thread + (thread:map-over-threads + #'(lambda (thread) + (when (eql (getf (thread:thread-plist thread) 'id) id) + (return-from find-thread thread)))))) + +(defimplementation thread-name (thread) + (princ-to-string (thread:thread-name thread))) + +(defimplementation thread-status (thread) + (let ((dynamic-values (thread::thread-dynamic-values thread))) + (if (zerop dynamic-values) "Exited" "Running"))) + +(defimplementation make-lock (&key name) + (thread:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (thread:with-lock-held (lock) (funcall function))) + +(defimplementation current-thread () + thread:*thread*) + +(defimplementation all-threads () + (let ((all-threads nil)) + (thread:map-over-threads #'(lambda (thread) (push thread all-threads))) + all-threads)) + +(defimplementation interrupt-thread (thread fn) + (thread:thread-interrupt thread #'(lambda () + (sys:with-interrupts + (funcall fn))))) + +(defimplementation kill-thread (thread) + (thread:destroy-thread thread)) + +(defimplementation thread-alive-p (thread) + (not (zerop (thread::thread-dynamic-values thread)))) + +(defvar *mailbox-lock* (thread:make-lock "Mailbox lock")) + +(defstruct (mailbox) + (lock (thread:make-lock "Thread mailbox" :type :error-check + :interruptible nil) + :type thread:error-check-lock) + (queue '() :type list)) + +(defun mailbox (thread) + "Return 'thread's mailbox." + (thread:with-lock-held (*mailbox-lock*) + (or (getf (thread:thread-plist thread) 'mailbox) + (setf (getf (thread:thread-plist thread) 'mailbox) (make-mailbox))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (lock (mailbox-lock mbox))) + (sys:without-interrupts + (thread:with-lock-held (lock "Mailbox Send") + (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) + (list message))))) + (mp:process-wakeup thread) + message)) + +(defimplementation receive () + (let* ((mbox (mailbox thread:*thread*)) + (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)))))) + + + +(defimplementation emacs-connected ()) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;; In SCL, we have: +;; (trace <name>) +;; (trace (method <name> <qualifier>? (<specializer>+))) +;; (trace :methods t '<name>) ;;to trace all methods of the gf <name> +;; <name> can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + nil) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ;; this isn't actually supported + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +;;; Weak datastructures + +;;; Not implemented in SCL. +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) + +;; Local Variables: +;; pbook-heading-regexp: "^;;;\(;+\)" +;; pbook-commentary-regexp: "^;;;\($\|[^;]\)" +;; End:
Added: branches/trunk-reorg/thirdparty/slime/swank-source-file-cache.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-source-file-cache.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-source-file-cache.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,118 @@ +;;;; Source-file cache +;;; +;;; To robustly find source locations in CMUCL and SBCL it's useful to +;;; have the exact source code that the loaded code was compiled from. +;;; In this source we can accurately find the right location, and from +;;; that location we can extract a "snippet" of code to show what the +;;; definition looks like. Emacs can use this snippet in a best-match +;;; search to locate the right definition, which works well even if +;;; the buffer has been modified. +;;; +;;; The idea is that if a definition previously started with +;;; `(define-foo bar' then it probably still does. +;;; +;;; Whenever we see that the file on disk has the same +;;; `file-write-date' as a location we're looking for we cache the +;;; whole file inside Lisp. That way we will still have the matching +;;; version even if the file is later modified on disk. If the file is +;;; later recompiled and reloaded then we replace our cache entry. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(in-package :swank-backend) + +(defvar *cache-sourcecode* t + "When true complete source files are cached. +The cache is used to keep known good copies of the source text which +correspond to the loaded code. Finding definitions is much more +reliable when the exact source is available, so we cache it in case it +gets edited on disk later.") + +(defvar *source-file-cache* (make-hash-table :test 'equal) + "Cache of source file contents. +Maps from truename to source-cache-entry structure.") + +(defstruct (source-cache-entry + (:conc-name source-cache-entry.) + (:constructor make-source-cache-entry (text date))) + text date) + +(defimplementation buffer-first-change (filename) + "Load a file into the cache when the user modifies its buffer. +This is a win if the user then saves the file and tries to M-. into it." + (unless (source-cached-p filename) + (ignore-errors + (source-cache-get filename (file-write-date filename)))) + nil) + +(defun get-source-code (filename code-date) + "Return the source code for FILENAME as written on DATE in a string. +If the exact version cannot be found then return the current one from disk." + (or (source-cache-get filename code-date) + (read-file filename))) + +(defun source-cache-get (filename date) + "Return the source code for FILENAME as written on DATE in a string. +Return NIL if the right version cannot be found." + (when *cache-sourcecode* + (let ((entry (gethash filename *source-file-cache*))) + (cond ((and entry (equal date (source-cache-entry.date entry))) + ;; Cache hit. + (source-cache-entry.text entry)) + ((or (null entry) + (not (equal date (source-cache-entry.date entry)))) + ;; Cache miss. + (if (equal (file-write-date filename) date) + ;; File on disk has the correct version. + (let ((source (read-file filename))) + (setf (gethash filename *source-file-cache*) + (make-source-cache-entry source date)) + source) + nil)))))) + +(defun source-cached-p (filename) + "Is any version of FILENAME in the source cache?" + (if (gethash filename *source-file-cache*) t)) + +(defun read-file (filename) + "Return the entire contents of FILENAME as a string." + (with-open-file (s filename :direction :input + :external-format (or (guess-external-format filename) + (find-external-format "latin-1") + :default)) + (let ((string (make-string (file-length s)))) + (read-sequence string s) + string))) + +;;;; Snippets + +(defvar *source-snippet-size* 256 + "Maximum number of characters in a snippet of source code. +Snippets at the beginning of definitions are used to tell Emacs what +the definitions looks like, so that it can accurately find them by +text search.") + +(defun read-snippet (stream &optional position) + "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. +If POSITION is given, set the STREAM's file position first." + (when position + (file-position stream position)) + #+SBCL (skip-comments-and-whitespace stream) + (read-upto-n-chars stream *source-snippet-size*)) + +(defun skip-comments-and-whitespace (stream) + (case (peek-char nil stream) + ((#\Space #\Tab #\Newline #\Linefeed) + (read-char stream) + (skip-comments-and-whitespace stream)) + (#; + (read-line stream) + (skip-comments-and-whitespace stream)))) + +(defun read-upto-n-chars (stream n) + "Return a string of upto N chars from STREAM." + (let* ((string (make-string n)) + (chars (read-sequence string stream))) + (subseq string 0 chars))) +
Added: branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,131 @@ +;;;; Source-paths + +;;; CMUCL/SBCL use a data structure called "source-path" to locate +;;; subforms. The compiler assigns a source-path to each form in a +;;; compilation unit. Compiler notes usually contain the source-path +;;; of the error location. +;;; +;;; Compiled code objects don't contain source paths, only the +;;; "toplevel-form-number" and the (sub-) "form-number". To get from +;;; the form-number to the source-path we need the entire toplevel-form +;;; (i.e. we have to read the source code). CMUCL has already some +;;; utilities to do this translation, but we use some extended +;;; versions, because we need more exact position info. Apparently +;;; Hemlock is happy with the position of the toplevel-form; we also +;;; need the position of subforms. +;;; +;;; We use a special readtable to get the positions of the subforms. +;;; The readtable stores the start and end position for each subform in +;;; hashtable for later retrieval. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +;;; Taken from swank-cmucl.lisp, by Helmut Eller + +(in-package :swank-backend) + +;; Some test to ensure the required conformance +(let ((rt (copy-readtable nil))) + (assert (or (not (get-macro-character #\space rt)) + (nth-value 1 (get-macro-character #\space rt)))) + (assert (not (get-macro-character #\ rt)))) + +(defun make-source-recorder (fn source-map) + "Return a macro character function that does the same as FN, but +additionally stores the result together with the stream positions +before and after of calling FN in the hashtable SOURCE-MAP." + (declare (type function fn)) + (lambda (stream char) + (let ((start (file-position stream)) + (values (multiple-value-list (funcall fn stream char))) + (end (file-position stream))) + ;;(format t "[~D ~{~A~^, ~} ~D ~D]~%" start values end (char-code char)) + (unless (null values) + (push (cons start end) (gethash (car values) source-map))) + (values-list values)))) + +(defun make-source-recording-readtable (readtable source-map) + "Return a source position recording copy of READTABLE. +The source locations are stored in SOURCE-MAP." + (let* ((tab (copy-readtable readtable)) + (*readtable* tab)) + (dotimes (code 128) + (let ((char (code-char code))) + (multiple-value-bind (fn term) (get-macro-character char tab) + (when fn + (set-macro-character char (make-source-recorder fn source-map) + term tab))))) + (suppress-sharp-dot tab) + tab)) + +(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)) + (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))) + +(defun read-source-form (n stream) + "Read the Nth toplevel form number with source location recording. +Return the form and the source-map." + (let ((*read-suppress* t)) + (dotimes (i n) + (read stream))) + (let ((*read-suppress* nil) + (*read-eval* nil)) + (read-and-record-source-map stream))) + +(defun source-path-stream-position (path stream) + "Search the source-path PATH in STREAM and return its position." + (check-source-path path) + (destructuring-bind (tlf-number . path) path + (multiple-value-bind (form source-map) (read-source-form tlf-number stream) + (source-path-source-position (cons 0 path) form source-map)))) + +(defun check-source-path (path) + (unless (and (consp path) + (every #'integerp path)) + (error "The source-path ~S is not valid." path))) + +(defun source-path-string-position (path string) + (with-input-from-string (s string) + (source-path-stream-position path s))) + +(defun source-path-file-position (path filename) + (with-open-file (file filename) + (source-path-stream-position path file))) + +(defun source-path-source-position (path form source-map) + "Return the start position of PATH from FORM and SOURCE-MAP. All +subforms along the path are considered and the start and end position +of the deepest (i.e. smallest) possible form is returned." + ;; compute all subforms along path + (let ((forms (loop for n in path + for f = form then (nth n f) + collect f))) + ;; select the first subform present in source-map + (loop for form in (reverse forms) + for positions = (gethash form source-map) + until (and positions (null (cdr positions))) + finally (destructuring-bind ((start . end)) positions + (return (values (1- start) end)))))) +
Added: branches/trunk-reorg/thirdparty/slime/swank.asd =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank.asd 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank.asd 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,48 @@ +;;; -*- lisp -*- + +;; ASDF system definition for loading the Swank server independently +;; of Emacs. +;; +;; This is only useful if you want to start a Swank server in a Lisp +;; processes that doesn't run under Emacs. Lisp processes created by +;; `M-x slime' automatically start the server. + +;; Usage: +;; +;; (require :swank) +;; (swank:create-swank-server PORT) => ACTUAL-PORT +;; +;; (PORT can be zero to mean "any available port".) +;; Then the Swank server is running on localhost:ACTUAL-PORT. You can +;; use `M-x slime-connect' to connect Emacs to it. +;; +;; This code has been placed in the Public Domain. All warranties +;; are disclaimed. + +(defpackage :swank-loader + (:use :cl)) + +(in-package :swank-loader) + +(defclass cl-script-file (asdf:source-file) ()) + +(defmethod asdf:perform ((o asdf:compile-op) (f cl-script-file)) + t) +(defmethod asdf:perform ((o asdf:load-op) (f cl-script-file)) + (mapcar #'load (asdf:input-files o f))) +(defmethod asdf:output-files ((o asdf:compile-op) (f cl-script-file)) + nil) +(defmethod asdf:input-files ((o asdf:load-op) (c cl-script-file)) + (list (asdf:component-pathname c))) +(defmethod asdf:operation-done-p ((o asdf:compile-op) (c cl-script-file)) + t) +(defmethod asdf:source-file-type ((c cl-script-file) (s asdf:module)) + "lisp") + +(asdf:defsystem :swank + :default-component-class cl-script-file + :components ((:file "swank-loader"))) + +(defparameter *source-directory* + (asdf:component-pathname (asdf:find-system :swank))) +
Added: branches/trunk-reorg/thirdparty/slime/swank.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/swank.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/swank.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,3198 @@ +;;; -*- outline-regexp:";;;;;*" indent-tabs-mode:nil coding:latin-1-unix -*- +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; +;;;; swank.lisp +;;; +;;; This file defines the "Swank" TCP server for Emacs to talk to. The +;;; code in this file is purely portable Common Lisp. We do require a +;;; smattering of non-portable functions in order to write the server, +;;; so we have defined them in `swank-backend.lisp' and implemented +;;; them separately for each Lisp implementation. These extensions are +;;; available to us here via the `SWANK-BACKEND' package. + +(defpackage :swank + (:use :common-lisp :swank-backend) + (:export #:startup-multiprocessing + #:start-server + #:create-server + #:ed-in-emacs + #:inspect-in-emacs + #:print-indentation-lossage + #:swank-debugger-hook + #:run-after-init-hook + #:inspect-for-emacs + #:inspect-slot-for-emacs + ;; 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* + #:*global-debugger* + #:*sldb-printer-bindings* + #:*swank-pprint-bindings* + #:*default-worker-thread-bindings* + #:*macroexpand-printer-bindings* + #:*record-repl-results* + #:*debug-on-swank-error* + ;; These are re-exported directly from the backend: + #:buffer-first-change + #:frame-source-location-for-emacs + #:restart-frame + #:sldb-step + #:sldb-break + #:sldb-break-on-return + #:profiled-functions + #:profile-report + #:profile-reset + #:unprofile-all + #:profile-package + #:default-directory + #:set-default-directory + #:quit-lisp)) + +(in-package :swank) + + +;;;; Top-level variables, constants, macros + +(defconstant cl-package (find-package :cl) + "The COMMON-LISP package.") + +(defconstant keyword-package (find-package :keyword) + "The KEYWORD package.") + +(defvar *canonical-package-nicknames* + `((:common-lisp-user . :cl-user)) + "Canonical package names to use instead of shortest name/nickname.") + +(defvar *auto-abbreviate-dotted-packages* t + "Abbreviate dotted package names to their last component if T.") + +(defvar *swank-io-package* + (let ((package (make-package :swank-io-package :use '()))) + (import '(nil t quote) package) + package)) + +(defconstant default-server-port 4005 + "The default TCP port for the server (when started manually).") + +(defvar *swank-debug-p* t + "When true, print extra debugging information.") + +(defvar *redirect-io* t + "When non-nil redirect Lisp standard I/O to Emacs. +Redirection is done while Lisp is processing a request for Emacs.") + +(defvar *sldb-printer-bindings* + `((*print-pretty* . t) + (*print-level* . 4) + (*print-length* . 10) + (*print-circle* . t) + (*print-readably* . nil) + (*print-pprint-dispatch* . ,(copy-pprint-dispatch nil)) + (*print-gensym* . t) + (*print-base* . 10) + (*print-radix* . nil) + (*print-array* . t) + (*print-lines* . 10) + (*print-escape* . t) + (*print-right-margin* . 70)) + "A set of printer variables used in the debugger.") + +(defvar *default-worker-thread-bindings* '() + "An alist to initialize dynamic variables in worker threads. +The list has the form ((VAR . VALUE) ...). Each variable VAR will be +bound to the corresponding VALUE.") + +(defun call-with-bindings (alist fun) + "Call FUN with variables bound according to ALIST. +ALIST is a list of the form ((VAR . VAL) ...)." + (let* ((rlist (reverse alist)) + (vars (mapcar #'car rlist)) + (vals (mapcar #'cdr rlist))) + (progv vars vals + (funcall fun)))) + +(defmacro with-bindings (alist &body body) + "See `call-with-bindings'." + `(call-with-bindings ,alist (lambda () ,@body))) + +;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via +;;; RPC. + +(defmacro defslimefun (name arglist &body rest) + "A DEFUN for functions that Emacs can call by RPC." + `(progn + (defun ,name ,arglist ,@rest) + ;; see http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name :swank)))) + +(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 +must always be supplied. This way the :TYPE slot option need not +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 +;;; simple indirection. The interface is more CLish than the Emacs +;;; Lisp one. + +(defmacro add-hook (place function) + "Add FUNCTION to the list of values on PLACE." + `(pushnew ,function ,place)) + +(defun run-hook (functions &rest arguments) + "Call each of FUNCTIONS with ARGUMENTS." + (dolist (function functions) + (apply function arguments))) + +(defvar *new-connection-hook* '() + "This hook is run each time a connection is established. +The connection structure is given as the argument. +Backend code should treat the connection structure as opaque.") + +(defvar *connection-closed-hook* '() + "This hook is run when a connection is closed. +The connection as passed as an argument. +Backend code should treat the connection structure as opaque.") + +(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 +;;; Emacs and Lisp. Each has a socket stream, a set of user I/O +;;; streams that redirect to Emacs, and optionally a second socket +;;; used solely to pipe user-output to Emacs (an optimization). +;;; + +(defstruct (connection + (:conc-name connection.) + (:print-function print-connection)) + ;; Raw I/O stream of socket connection. + (socket-io (missing-arg) :type stream :read-only t) + ;; Optional dedicated output socket (backending `user-output' slot). + ;; Has a slot so that it can be closed with the connection. + (dedicated-output nil :type (or stream null)) + ;; Streams that can be used for user interaction, with requests + ;; redirected to Emacs. + (user-input nil :type (or stream null)) + (user-output nil :type (or stream null)) + (user-io nil :type (or stream null)) + ;; A stream that we use for *trace-output*; if nil, we user user-output. + (trace-output nil :type (or stream null)) + ;; A stream where we send REPL results. + (repl-results nil :type (or stream null)) + ;; In multithreaded systems we delegate certain tasks to specific + ;; threads. The `reader-thread' is responsible for reading network + ;; requests from Emacs and sending them to the `control-thread'; the + ;; `control-thread' is responsible for dispatching requests to the + ;; threads that should handle them; the `repl-thread' is the one + ;; that evaluates REPL expressions. The control thread dispatches + ;; all REPL evaluations to the REPL thread and for other requests it + ;; spawns new threads. + reader-thread + control-thread + repl-thread + ;; Callback functions: + ;; (SERVE-REQUESTS <this-connection>) serves all pending requests + ;; from Emacs. + (serve-requests (missing-arg) :type function) + ;; (READ) is called to read and return one message from Emacs. + (read (missing-arg) :type function) + ;; (SEND OBJECT) is called to send one message to Emacs. + (send (missing-arg) :type function) + ;; (CLEANUP <this-connection>) is called when the connection is + ;; closed. + (cleanup nil :type (or null function)) + ;; Cache of macro-indentation information that has been sent to Emacs. + ;; This is used for preparing deltas to update Emacs's knowledge. + ;; Maps: symbol -> indentation-specification + (indentation-cache (make-hash-table :test 'eq) :type hash-table) + ;; The list of packages represented in the cache: + (indentation-cache-packages '()) + ;; The communication style used. + (communication-style nil :type (member nil :spawn :sigio :fd-handler)) + ;; The coding system for network streams. + (coding-system )) + +(defun print-connection (conn stream depth) + (declare (ignore depth)) + (print-unreadable-object (conn stream :type t :identity t))) + +(defvar *connections* '() + "List of all active connections, with the most recent at the front.") + +(defvar *emacs-connection* nil + "The connection to Emacs currently in use.") + +(defvar *swank-state-stack* '() + "A list of symbols describing the current state. Used for debugging +and to detect situations where interrupts can be ignored.") + +(defun default-connection () + "Return the 'default' Emacs connection. +This connection can be used to talk with Emacs when no specific +connection is in use, i.e. *EMACS-CONNECTION* is NIL. + +The default connection is defined (quite arbitrarily) as the most +recently established one." + (first *connections*)) + +(defslimefun state-stack () + "Return the value of *SWANK-STATE-STACK*." + *swank-state-stack*) + +;; 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) + (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)) + + +;;;; Utilities + +;;;;; Helper macros + +(defmacro with-io-redirection ((connection) &body body) + "Execute BODY I/O redirection to CONNECTION. +If *REDIRECT-IO* is true then all standard I/O streams are redirected." + `(maybe-call-with-io-redirection ,connection (lambda () ,@body))) + +(defun maybe-call-with-io-redirection (connection fun) + (if *redirect-io* + (call-with-redirected-io connection fun) + (funcall fun))) + +(defmacro with-connection ((connection) &body body) + "Execute BODY in the context of CONNECTION." + `(call-with-connection ,connection (lambda () ,@body))) + +(defun call-with-connection (connection fun) + (let ((*emacs-connection* connection)) + (with-io-redirection (*emacs-connection*) + (call-with-debugger-hook #'swank-debugger-hook fun)))) + +(defmacro without-interrupts (&body body) + `(call-without-interrupts (lambda () ,@body))) + +(defmacro destructure-case (value &rest patterns) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (gensym "op-")) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (case ,operator + ,@(loop for (pattern . body) in patterns collect + (if (eq pattern t) + `(t ,@body) + (destructuring-bind (op &rest rands) pattern + `(,op (destructuring-bind ,rands ,operands + ,@body))))) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "destructure-case failed: ~S" ,tmp)))))))) + +(defmacro with-temp-package (var &body body) + "Execute BODY with VAR bound to a temporary package. +The package is deleted before returning." + `(let ((,var (make-package (gensym "TEMP-PACKAGE-")))) + (unwind-protect (progn ,@body) + (delete-package ,var)))) + +(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))))) + + +;;;;; Logging + +(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." + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-pretty* nil) + (*package* *swank-io-package*)) + (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)) + + +;;;;; Misc + +(defun length= (seq n) + "Test for whether SEQ contains N number of elements. I.e. it's equivalent + to (= (LENGTH SEQ) N), but besides being more concise, it may also be more + efficiently implemented." + (etypecase seq + (list (do ((i n (1- i)) + (list seq (cdr list))) + ((or (<= i 0) (null list)) + (and (zerop i) (null list))))) + (sequence (= (length seq) n)))) + +(defun ensure-list (thing) + (if (listp thing) thing (list thing))) + +(defun recursively-empty-p (list) + "Returns whether LIST consists only of arbitrarily nested empty lists." + (cond ((not (listp list)) nil) + ((null list) t) + (t (every #'recursively-empty-p list)))) + +(defun maybecall (bool fn &rest args) + "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values." + (if bool (apply fn args) (values-list args))) + +(defun exactly-one-p (&rest values) + "If exactly one value in VALUES is non-NIL, this value is returned. +Otherwise NIL is returned." + (let ((found nil)) + (dolist (v values) + (when v (if found + (return-from exactly-one-p nil) + (setq found v)))) + found)) + + +;;;;; Symbols + +(defun symbol-status (symbol &optional (package (symbol-package symbol))) + "Returns one of + + :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol, + + :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol, + + :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE, + but is not _present_ in PACKAGE, + + or NIL if SYMBOL is not _accessible_ in PACKAGE. + + +Be aware not to get confused with :INTERNAL and how "internal +symbols" are defined in the spec; there is a slight mismatch of +definition with the Spec and what's commonly meant when talking +about internal symbols most times. As the spec says: + + In a package P, a symbol S is + + _accessible_ if S is either _present_ in P itself or was + inherited from another package Q (which implies + that S is _external_ in Q.) + + You can check that with: (AND (SYMBOL-STATUS S P) T) + + + _present_ if either P is the /home package/ of S or S has been + imported into P or exported from P by IMPORT, or + EXPORT respectively. + + Or more simply, if S is not _inherited_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :INHERITED)))) + + + _external_ if S is going to be inherited into any package that + /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or + DEFPACKAGE. + + Note that _external_ implies _present_, since to + make a symbol _external_, you'd have to use EXPORT + which will automatically make the symbol _present_. + + You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL) + + + _internal_ if S is _accessible_ but not _external_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :EXTERNAL)))) + + + Notice that this is *different* to + (EQ (SYMBOL-STATUS S P) :INTERNAL) + because what the spec considers _internal_ is split up into two + explicit pieces: :INTERNAL, and :INHERITED; just as, for instance, + CL:FIND-SYMBOL does. + + The rationale is that most times when you speak about "internal" + symbols, you're actually not including the symbols inherited + from other packages, but only about the symbols directly specific + to the package in question. +" + (when package ; may be NIL when symbol is completely uninterned. + (check-type symbol symbol) (check-type package package) + (multiple-value-bind (present-symbol status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol present-symbol) status)))) + +(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." + (eq (symbol-status symbol package) :external)) + + +(defun classify-symbol (symbol) + "Returns a list of classifiers that classify SYMBOL according +to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a +special variable.) The list may contain the following classification +keywords: :BOUNDP, :FBOUNDP, :GENERIC-FUNCTION, :CLASS, :MACRO, +:SPECIAL-OPERATOR, and/or :PACKAGE" + (check-type symbol symbol) + (let (result) + (when (boundp symbol) (push :boundp result)) + (when (fboundp symbol) (push :fboundp result)) + (when (find-class symbol nil) (push :class result)) + (when (macro-function symbol) (push :macro result)) + (when (special-operator-p symbol) (push :special-operator result)) + (when (find-package symbol) (push :package result)) + (when (typep (ignore-errors (fdefinition symbol)) + 'generic-function) + (push :generic-function result)) + result)) + +(defun symbol-classification->string (flags) + (format nil "~A~A~A~A~A~A~A" + (if (member :boundp flags) "b" "-") + (if (member :fboundp flags) "f" "-") + (if (member :generic-function flags) "g" "-") + (if (member :class flags) "c" "-") + (if (member :macro flags) "m" "-") + (if (member :special-operator flags) "s" "-") + (if (member :package flags) "p" "-"))) + + +;;;; TCP Server + +(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 *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." + (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 *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 + (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))) + +(defparameter *loopback-interface* "127.0.0.1") + +(defun setup-server (port announce-fn style dont-close external-format) + (declare (type function announce-fn)) + (let* ((socket (create-socket *loopback-interface* port)) + (port (local-port socket))) + (funcall announce-fn port) + (flet ((serve () + (serve-connection socket style dont-close external-format))) + (ecase style + (:spawn + (spawn (lambda () (loop do (ignore-errors (serve)) while dont-close)) + :name "Swank")) + ((:fd-handler :sigio) + (add-fd-handler socket (lambda () (serve)))) + ((nil) (loop do (serve) while dont-close))) + port))) + +(defun serve-connection (socket style dont-close external-format) + (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)) + (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 () + "Finds the magic secret from the user's home directory. Returns nil +if the file doesn't exist; otherwise the first line of the file." + (with-open-file (in + (merge-pathnames (user-homedir-pathname) #p".slime-secret") + :if-does-not-exist nil) + (and in (read-line in nil "")))) + +(defun serve-requests (connection) + "Read and process all requests on connections." + (funcall (connection.serve-requests connection) connection)) + +(defun announce-server-port (file port) + (with-open-file (s file + :direction :output + :if-exists :error + :if-does-not-exist :create) + (format s "~S~%" port)) + (simple-announce-function port)) + +(defun simple-announce-function (port) + (when *swank-debug-p* + (format *log-output* "~&;; Swank started at port: ~D.~%" port) + (force-output *log-output*))) + +(defun open-streams (connection) + "Return the 5 streams for IO redirection: +DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" + (multiple-value-bind (output-fn dedicated-output) + (make-output-function connection) + (let ((input-fn + (lambda () + (with-connection (connection) + (with-simple-restart (abort-read + "Abort reading input from Emacs.") + (read-user-input-from-emacs)))))) + (multiple-value-bind (in out) (make-fn-streams input-fn output-fn) + (let ((out (or dedicated-output out))) + (let ((io (make-two-way-stream in out))) + (mapc #'make-stream-interactive (list in out io)) + (let ((repl-results + (make-output-stream-for-target connection :repl-result))) + (values dedicated-output in out io repl-results)))))))) + +(defun make-output-function (connection) + "Create function to send user output to Emacs. +This function may open a dedicated socket to send output. It +returns two values: the output function, and the dedicated +stream (or NIL if none was created)." + (if *use-dedicated-output-stream* + (let ((stream (open-dedicated-output-stream + (connection.socket-io connection)))) + (values (lambda (string) + (write-string string stream) + (force-output stream)) + stream)) + (values (lambda (string) + (with-connection (connection) + (with-simple-restart + (abort "Abort sending output to Emacs.") + (send-to-emacs `(:write-string ,string))))) + nil))) + +(defun make-output-function-for-target (connection target) + "Create a function to send user output to a specific TARGET in Emacs." + (lambda (string) + (with-connection (connection) + (with-simple-restart + (abort "Abort sending output to Emacs.") + (send-to-emacs `(:write-string ,string ,target)))))) + +(defun make-output-stream-for-target (connection target) + "Create a stream that sends output to a specific TARGET in Emacs." + (nth-value 1 (make-fn-streams + (lambda () + (error "Should never be called")) + (make-output-function-for-target connection target)))) + +(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* + *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))))) + +(defvar *sldb-quit-restart* 'abort + "What restart should swank attempt to invoke when the user sldb-quits.") + +(defun handle-request (connection) + "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))) + (with-connection (connection) + (with-simple-restart (abort "Return to SLIME's top level.") + (let ((*sldb-quit-restart* (find-restart 'abort))) + (read-from-emacs)))))) + +(defun current-socket-io () + (connection.socket-io *emacs-connection*)) + +(defun close-connection (c &optional condition backtrace) + (format *log-output* "~&;; swank:close-connection: ~A~%" condition) + (let ((cleanup (connection.cleanup c))) + (when cleanup + (funcall cleanup c))) + (close (connection.socket-io c)) + (when (connection.dedicated-output c) + (close (connection.dedicated-output c))) + (setf *connections* (remove c *connections*)) + (run-hook *connection-closed-hook* c) + (when (and condition (not (typep condition 'end-of-file))) + (finish-output *log-output*) + (format *log-output* "~&;; Event history start:~%") + (dump-event-history *log-output*) + (format *log-output* ";; 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 *log-output*))) + +(defvar *debug-on-swank-error* nil + "When non-nil internal swank errors will drop to a + debugger (not an sldb buffer). Do not set this to T unless you + want to debug swank internals.") + +(defmacro with-reader-error-handler ((connection) &body body) + (let ((con (gensym)) + (blck (gensym))) + `(let ((,con ,connection)) + (block ,blck + (handler-bind ((swank-error + (lambda (e) + (if *debug-on-swank-error* + (invoke-debugger e) + (return-from ,blck + (close-connection + ,con + (swank-error.condition e) + (swank-error.backtrace e))))))) + (progn ,@body)))))) + +(defslimefun simple-break () + (with-simple-restart (continue "Continue from interrupt.") + (call-with-debugger-hook + #'swank-debugger-hook + (lambda () + (invoke-debugger + (make-condition 'simple-error + :format-control "Interrupt from Emacs"))))) + nil) + +;;;;;; Thread based communication + +(defvar *active-threads* '()) + +(defun read-loop (control-thread input-stream connection) + (with-reader-error-handler (connection) + (loop (send control-thread (decode-message input-stream))))) + +(defun dispatch-loop (socket-io connection) + (let ((*emacs-connection* connection)) + (handler-bind ((error (lambda (e) + (if *debug-on-swank-error* + (invoke-debugger e) + (return-from dispatch-loop + (close-connection connection e)))))) + (loop (dispatch-event (receive) socket-io))))) + +(defun repl-thread (connection) + (let ((thread (connection.repl-thread connection))) + (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) + (car *active-threads*)) + ((member :repl-thread) + (repl-thread *emacs-connection*)) + (fixnum + (find-thread id)))) + +(defun interrupt-worker-thread (id) + (let ((thread (or (find-worker-thread id) + (repl-thread *emacs-connection*)))) + (interrupt-thread thread #'simple-break))) + +(defun thread-for-evaluation (id) + "Find or create a thread to evaluate the next request." + (let ((c *emacs-connection*)) + (etypecase id + ((member t) + (spawn-worker-thread c)) + ((member :repl-thread) + (repl-thread c)) + (fixnum + (find-thread id))))) + +(defun spawn-worker-thread (connection) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (handle-request connection))) + :name "worker")) + +(defun spawn-repl-thread (connection name) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (repl-loop connection))) + :name name)) + +(defun dispatch-event (event socket-io) + "Handle an event triggered either by Emacs or within Lisp." + (log-event "DISPATCHING: ~S~%" event) + (destructure-case event + ((:emacs-rex form package thread-id id) + (let ((thread (thread-for-evaluation thread-id))) + (push thread *active-threads*) + (send thread `(eval-for-emacs ,form ,package ,id)))) + ((:return thread &rest args) + (let ((tail (member thread *active-threads*))) + (setq *active-threads* (nconc (ldiff *active-threads* tail) + (cdr tail)))) + (encode-message `(:return ,@args) socket-io)) + ((:emacs-interrupt thread-id) + (interrupt-worker-thread thread-id)) + (((:debug :debug-condition :debug-activate :debug-return) + thread &rest args) + (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)) + ((: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) + (send (find-thread thread-id) `(take-input ,tag ,string))) + ((:eval thread &rest args) + (encode-message `(:eval ,(thread-id thread) ,@args) socket-io)) + ((:emacs-return thread-id tag value) + (send (find-thread thread-id) `(take-input ,tag ,value))) + (((:write-string :presentation-start :presentation-end + :new-package :new-features :ed :%apply :indentation-update + :eval-no-wait :background-message :inspect) + &rest _) + (declare (ignore _)) + (encode-message event socket-io)))) + +(defun spawn-threads-for-connection (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) + (when (and thread + (thread-alive-p thread) + (not (equal (current-thread) thread))) + (kill-thread thread))))) + +(defun repl-loop (connection) + (loop (handle-request connection))) + +(defun process-available-input (stream fn) + (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) + (let ((client (connection.socket-io connection))) + (flet ((handler () + (cond ((null *swank-state-stack*) + (with-reader-error-handler (connection) + (process-available-input + client (lambda () (handle-request connection))))) + ((eq (car *swank-state-stack*) :read-next-form)) + (t (process-available-input client #'read-from-emacs))))) + (add-sigio-handler client #'handler) + (handler)))) + +(defun deinstall-sigio-handler (connection) + (remove-sigio-handlers (connection.socket-io connection))) + +;;;;;; SERVE-EVENT based IO + +(defun install-fd-handler (connection) + (let ((client (connection.socket-io connection))) + (flet ((handler () + (cond ((null *swank-state-stack*) + (with-reader-error-handler (connection) + (process-available-input + client (lambda () (handle-request connection))))) + ((eq (car *swank-state-stack*) :read-next-form)) + (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)))) + +(defun deinstall-fd-handler (connection) + (remove-fd-handlers (connection.socket-io connection))) + +;;;;;; Simple sequential IO + +(defun simple-serve-requests (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)))) + (log-event "DISPATCHING: ~S~%" event) + (destructure-case event + ((:emacs-rex form package thread id) + (declare (ignore thread)) + `(eval-for-emacs ,form ,package ,id)) + ((:emacs-interrupt thread) + (declare (ignore thread)) + '(simple-break)) + ((:emacs-return-string thread tag string) + (declare (ignore thread)) + `(take-input ,tag ,string)) + ((:emacs-return thread tag value) + (declare (ignore thread)) + `(take-input ,tag ,value))))) + +(defun send-to-socket-io (event) + (log-event "DISPATCHING: ~S~%" event) + (flet ((send (o) + (without-interrupts + (encode-message o (current-socket-io))))) + (destructure-case event + (((:debug-activate :debug :debug-return :read-string :read-aborted + :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))) + (((:write-string :new-package :new-features :debug-condition + :presentation-start :presentation-end + :indentation-update :ed :%apply :eval-no-wait + :background-message :inspect) + &rest _) + (declare (ignore _)) + (send event))))) + +(defun initialize-streams-for-connection (connection) + (multiple-value-bind (dedicated in out io repl-results) + (open-streams connection) + (setf (connection.dedicated-output connection) dedicated + (connection.user-io connection) io + (connection.user-output connection) out + (connection.user-input connection) in + (connection.repl-results connection) repl-results) + connection)) + +(defun 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 +;;; +;;; This code handles redirection of the standard I/O streams +;;; (`*standard-output*', etc) into Emacs. The `connection' structure +;;; contains the appropriate streams, so all we have to do is make the +;;; right bindings. + +;;;;; Global I/O redirection framework +;;; +;;; Optionally, the top-level global bindings of the standard streams +;;; can be assigned to be redirected to Emacs. When Emacs connects we +;;; redirect the streams into the connection, and they keep going into +;;; that connection even if more are established. If the connection +;;; handling the streams closes then another is chosen, or if there +;;; are no connections then we revert to the original (real) streams. +;;; +;;; It is slightly tricky to assign the global values of standard +;;; streams because they are often shadowed by dynamic bindings. We +;;; solve this problem by introducing an extra indirection via synonym +;;; streams, so that *STANDARD-INPUT* is a synonym stream to +;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current" +;;; variables, so they can always be assigned to affect a global +;;; change. + +(defvar *globally-redirect-io* nil + "When non-nil globally redirect all standard streams to Emacs.") + +;;;;; Global redirection setup + +(defvar *saved-global-streams* '() + "A plist to save and restore redirected stream objects. +E.g. the value for '*standard-output* holds the stream object +for *standard-output* before we install our redirection.") + +(defun setup-stream-indirection (stream-var &optional stream) + "Setup redirection scaffolding for a global stream variable. +Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro: + +1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'. + +2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as +*STANDARD-INPUT*. + +3. Assigns *STANDARD-INPUT* to a synonym stream pointing to +*CURRENT-STANDARD-INPUT*. + +This has the effect of making *CURRENT-STANDARD-INPUT* contain the +effective global value for *STANDARD-INPUT*. This way we can assign +the effective global value even when *STANDARD-INPUT* is shadowed by a +dynamic binding." + (let ((current-stream-var (prefixed-var '#:current stream-var)) + (stream (or stream (symbol-value stream-var)))) + ;; Save the real stream value for the future. + (setf (getf *saved-global-streams* stream-var) stream) + ;; Define a new variable for the effective stream. + ;; This can be reassigned. + (proclaim `(special ,current-stream-var)) + (set current-stream-var stream) + ;; Assign the real binding as a synonym for the current one. + (set stream-var (make-synonym-stream current-stream-var)))) + +(defun prefixed-var (prefix variable-symbol) + "(PREFIXED-VAR "FOO" '*BAR*) => SWANK::*FOO-BAR*" + (let ((basename (subseq (symbol-name variable-symbol) 1))) + (intern (format nil "*~A-~A" (string prefix) basename) :swank))) + +(defvar *standard-output-streams* + '(*standard-output* *error-output* *trace-output*) + "The symbols naming standard output streams.") + +(defvar *standard-input-streams* + '(*standard-input*) + "The symbols naming standard input streams.") + +(defvar *standard-io-streams* + '(*debug-io* *query-io* *terminal-io*) + "The symbols naming standard io streams.") + +(defun init-global-stream-redirection () + (when *globally-redirect-io* + (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) + (connection.user-output connection))) + ;; FIXME: If we redirect standard input to Emacs then we get the + ;; regular Lisp top-level trying to read from our REPL. + ;; + ;; Perhaps the ideal would be for the real top-level to run in a + ;; thread with local bindings for all the standard streams. Failing + ;; that we probably would like to inhibit it from reading while + ;; Emacs is connected. + ;; + ;; Meanwhile we just leave *standard-input* alone. + #+NIL + (dolist (i *standard-input-streams*) + (set (prefixed-var '#:current i) + (connection.user-input connection))) + (dolist (io *standard-io-streams*) + (set (prefixed-var '#:current io) + (connection.user-io connection)))) + +(defun revert-global-io-redirection () + "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams." + (dolist (stream-var (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)) + (set (prefixed-var '#:current stream-var) + (getf *saved-global-streams* stream-var)))) + +;;;;; Global redirection hooks + +(defvar *global-stdio-connection* nil + "The connection to which standard I/O streams are globally redirected. +NIL if streams are not globally redirected.") + +(defun maybe-redirect-global-io (connection) + "Consider globally redirecting to a newly-established CONNECTION." + (when (and *globally-redirect-io* (null *global-stdio-connection*)) + (setq *global-stdio-connection* connection) + (globally-redirect-io-to-connection connection))) + +(defun update-redirection-after-close (closed-connection) + "Update redirection after a connection closes." + (check-type closed-connection connection) + (when (eq *global-stdio-connection* closed-connection) + (if (and (default-connection) *globally-redirect-io*) + ;; Redirect to another connection. + (globally-redirect-io-to-connection (default-connection)) + ;; No more connections, revert to the real streams. + (progn (revert-global-io-redirection) + (setq *global-stdio-connection* nil))))) + +(add-hook *new-connection-hook* 'maybe-redirect-global-io) +(add-hook *connection-closed-hook* 'update-redirection-after-close) + +;;;;; Redirection during requests +;;; +;;; We always redirect the standard streams to Emacs while evaluating +;;; an RPC. This is done with simple dynamic bindings. + +(defun call-with-redirected-io (connection function) + "Call FUNCTION with I/O streams redirected via CONNECTION." + (declare (type function function)) + (let* ((io (connection.user-io connection)) + (in (connection.user-input connection)) + (out (connection.user-output connection)) + (trace (or (connection.trace-output connection) out)) + (*standard-output* out) + (*error-output* out) + (*trace-output* trace) + (*debug-io* io) + (*query-io* io) + (*standard-input* in) + (*terminal-io* io)) + (funcall function))) + +(defun read-from-emacs () + "Read and process a request from Emacs." + (apply #'funcall (funcall (connection.read *emacs-connection*)))) + +(defun read-from-control-thread () + (receive)) + +(defun decode-message (stream) + "Read an S-expression from STREAM using the SLIME protocol." + (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*))) + (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))) + (dotimes (i 6) + (setf (aref buffer i) (read-char stream))) + (parse-integer buffer :radix #x10))) + +(defun read-form (string) + (with-standard-io-syntax + (let ((*package* *swank-io-package*)) + (read-from-string string)))) + +(defvar *slime-features* nil + "The feature list that has been sent to Emacs.") + +(defun send-to-emacs (object) + "Send OBJECT to Emacs." + (funcall (connection.send *emacs-connection*) object)) + +(defun send-oob-to-emacs (object) + (send-to-emacs object)) + +(defun send-to-control-thread (object) + (send (connection.control-thread *emacs-connection*) object)) + +(defun encode-message (message stream) + (let* ((string (prin1-to-string-for-emacs message)) + (length (length string))) + (log-event "WRITE: ~A~%" string) + (let ((*print-pretty* nil)) + (format stream "~6,'0x" length)) + (write-string string stream) + ;;(terpri stream) + (finish-output stream))) + +(defun prin1-to-string-for-emacs (object) + (with-standard-io-syntax + (let ((*print-case* :downcase) + (*print-readably* nil) + (*print-pretty* nil) + (*package* *swank-io-package*)) + (prin1-to-string object)))) + +(defun force-user-output () + (force-output (connection.user-io *emacs-connection*)) + (finish-output (connection.user-output *emacs-connection*))) + +(defun clear-user-input () + (clear-input (connection.user-input *emacs-connection*))) + +(defvar *read-input-catch-tag* 0) + +(defun intern-catch-tag (tag) + ;; fixnums aren't eq in ABCL, so we use intern to create tags + (intern (format nil "~D" tag) :swank)) + +(defun read-user-input-from-emacs () + (let ((tag (incf *read-input-catch-tag*))) + (force-output) + (send-to-emacs `(:read-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 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 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-name +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 (concatenate 'string (when (eq (symbol-package form) + #.(find-package "KEYWORD")) + ":") + (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." + (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))))))) + +(defvar *swank-wire-protocol-version* nil + "The version of the swank/slime communication protocol.") + +(defslimefun connection-info () + "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*) + `(: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 + +(defmacro define-special (name doc) + "Define a special variable NAME with doc string DOC. +This is like defvar, but NAME will not be initialized." + `(progn + (defvar ,name) + (setf (documentation ',name 'variable) ,doc))) + +(define-special *buffer-package* + "Package corresponding to slime-buffer-package. + +EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime +buffer are best read in this package. See also FROM-STRING and TO-STRING.") + +(define-special *buffer-readtable* + "Readtable associated with the current buffer") + +(defmacro with-buffer-syntax ((&rest _) &body body) + "Execute BODY with appropriate *package* and *readtable* bindings. + +This should be used for code that is conceptionally executed in an +Emacs buffer." + (destructuring-bind () _ + `(call-with-buffer-syntax (lambda () ,@body)))) + +(defun call-with-buffer-syntax (fun) + (let ((*package* *buffer-package*)) + ;; Don't shadow *readtable* unnecessarily because that prevents + ;; the user from assigning to it. + (if (eq *readtable* *buffer-readtable*) + (call-with-syntax-hooks fun) + (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 () + (let ((*read-suppress* nil)) + (read-from-string string)))) + +;; FIXME: deal with #| etc. hard to do portably. +(defun tokenize-symbol (string) + "STRING is interpreted as the string representation of a symbol +and is tokenized accordingly. The result is returned in three +values: The package identifier part, the actual symbol identifier +part, and a flag if the STRING represents a symbol that is +internal to the package identifier part. (Notice that the flag is +also true with an empty package identifier part, as the STRING is +considered to represent a symbol internal to some current package.)" + (let ((package (let ((pos (position #: string))) + (if pos (subseq string 0 pos) nil))) + (symbol (let ((pos (position #: string :from-end t))) + (if pos (subseq string (1+ pos)) string))) + (internp (not (= (count #: string) 1)))) + (values symbol package internp))) + +(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 (or (not package) internp)))) + +(defun untokenize-symbol (package-name internal-p symbol-name) + "The inverse of TOKENIZE-SYMBOL. + + (untokenize-symbol "quux" nil "foo") ==> "quux:foo" + (untokenize-symbol "quux" t "foo") ==> "quux::foo" + (untokenize-symbol nil nil "foo") ==> "foo" +" + (cond ((not package-name) symbol-name) + (internal-p (cat package-name "::" symbol-name)) + (t (cat package-name ":" symbol-name)))) + +(defun casify-char (char) + "Convert CHAR accoring to readtable-case." + (ecase (readtable-case *readtable*) + (: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-thoroughly string) + (let ((package (cond ((string= pname "") keyword-package) + (pname (find-package pname)) + (t package)))) + (if package + (multiple-value-bind (symbol flag) (find-symbol sname package) + (values symbol flag sname package)) + (values nil nil nil nil))))) + +(defun parse-symbol-or-lose (string &optional (package *package*)) + (multiple-value-bind (symbol status) (parse-symbol string package) + (if status + (values symbol status) + (error "Unknown symbol: ~A [in ~A]" string package)))) + +;; FIXME: interns the name +(defun parse-package (string) + "Find the package named STRING. +Return the package or nil." + (multiple-value-bind (name pos) + (if (zerop (length string)) + (values :|| 0) + (let ((*package* *swank-io-package*)) + (ignore-errors (read-from-string string)))) + (and name + (or (symbolp name) + (stringp name)) + (= (length string) pos) + (find-package name)))) + +(defun unparse-name (string) + "Print the name STRING according to the current printer settings." + ;; this is intended for package or symbol names + (subseq (prin1-to-string (make-symbol string)) 2)) + +(defun guess-package (string) + "Guess which package corresponds to STRING. +Return nil if no package matches." + (or (find-package string) + (parse-package string) + (if (find #! string) ; for SBCL + (guess-package (substitute #- #! string))))) + +(defvar *readtable-alist* (default-readtable-alist) + "An alist mapping package names to readtables.") + +(defun guess-buffer-readtable (package-name) + (let ((package (guess-package package-name))) + (or (and package + (cdr (assoc (package-name package) *readtable-alist* + :test #'string=))) + *readtable*))) + + +;;;; Evaluation + +(defvar *pending-continuations* '() + "List of continuations for Emacs. (thread local)") + +(defun guess-buffer-package (string) + "Return a package for STRING. +Fall back to the the current if no such package exists." + (or (and string (guess-package string)) + *package*)) + +(defun eval-for-emacs (form buffer-package id) + "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM. +Return the result to the continuation ID. +Errors are trapped and invoke our debugger." + (call-with-debugger-hook + #'swank-debugger-hook + (lambda () + (let (ok result) + (unwind-protect + (let ((*buffer-package* (guess-buffer-package buffer-package)) + (*buffer-readtable* (guess-buffer-readtable buffer-package)) + (*pending-continuations* (cons id *pending-continuations*))) + (check-type *buffer-package* package) + (check-type *buffer-readtable* readtable) + ;; APPLY would be cleaner than EVAL. + ;;(setq result (apply (car form) (cdr form))) + (setq result (eval form)) + (run-hook *pre-reply-hook*) + (finish-output) + (setq ok t)) + (force-user-output) + (send-to-emacs `(:return ,(current-thread) + ,(if ok + `(:ok ,result) + `(:abort)) + ,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 (length= values 1) (integerp (car values))) + (let ((i (car 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) + (finish-output) + (format-values-for-echo-area values)))) + +(defslimefun eval-and-grab-output (string) + (with-buffer-syntax () + (let* ((s (make-string-output-stream)) + (*standard-output* s) + (values (multiple-value-list (eval (from-string string))))) + (list (get-output-stream-string s) + (format nil "~{~S~^~%~}" values))))) + +(defun eval-region (string) + "Evaluate STRING. +Return the results of the last form as a list and as secondary value the +last form." + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (return (values values -))) + (setq - form) + (setq values (multiple-value-list (eval form))) + (finish-output)))))) + +(defslimefun interactive-eval-region (string) + (with-buffer-syntax () + (format-values-for-echo-area (eval-region string)))) + +(defslimefun re-evaluate-defvar (form) + (with-buffer-syntax () + (let ((form (read-from-string form))) + (destructuring-bind (dv name &optional value doc) form + (declare (ignore value doc)) + (assert (eq dv 'defvar)) + (makunbound name) + (prin1-to-string (eval form)))))) + +(defvar *swank-pprint-bindings* + `((*print-pretty* . t) + (*print-level* . nil) + (*print-length* . nil) + (*print-circle* . t) + (*print-gensym* . t) + (*print-readably* . nil)) + "A list of variables bindings during pretty printing. +Used by pprint-eval.") + +(defun swank-pprint (list) + "Bind some printer variables and pretty print each object in LIST." + (with-buffer-syntax () + (with-bindings *swank-pprint-bindings* + (cond ((null list) "; No value") + (t (with-output-to-string (*standard-output*) + (dolist (o list) + (pprint o) + (terpri)))))))) + +(defslimefun pprint-eval (string) + (with-buffer-syntax () + (swank-pprint (multiple-value-list (eval (read-from-string string)))))) + +(defslimefun set-package (name) + "Set *package* to the package named NAME. +Return the full package-name and the string to use in the prompt." + (let ((p (guess-package name))) + (assert (packagep p)) + (setq *package* p) + (list (package-name p) (package-string-for-prompt p)))) + +;;;;; Listener eval + +(defvar *listener-eval-function* 'repl-eval) + +(defslimefun listener-eval (string) + (funcall *listener-eval-function* string)) + +(defvar *send-repl-results-function* 'send-repl-results-to-emacs) + +(defun repl-eval (string) + (clear-user-input) + (with-buffer-syntax () + (track-package + (lambda () + (multiple-value-bind (values last-form) (eval-region string) + (setq *** ** ** * * (car values) + /// // // / / values + +++ ++ ++ + + last-form) + (funcall *send-repl-results-function* values))))) + nil) + +(defun track-package (fun) + (let ((p *package*)) + (unwind-protect (funcall fun) + (unless (eq *package* p) + (send-to-emacs (list :new-package (package-name *package*) + (package-string-for-prompt *package*))))))) + +(defun send-repl-results-to-emacs (values) + (fresh-line) + (finish-output) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (dolist (v values) + (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline) + :repl-result))))) + +(defun cat (&rest strings) + "Concatenate all arguments and make the result a string." + (with-output-to-string (out) + (dolist (s strings) + (etypecase s + (string (write-string s out)) + (character (write-char s out)))))) + +(defun package-string-for-prompt (package) + "Return the shortest nickname (or canonical name) of PACKAGE." + (unparse-name + (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." + (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. + +N.B. this is not an actual package name or nickname." + (when *auto-abbreviate-dotted-packages* + (let ((last-dot (position #. (package-name package) :from-end t))) + (when last-dot (subseq (package-name package) (1+ last-dot)))))) + +(defun shortest-package-nickname (package) + "Return the shortest nickname (or canonical name) of PACKAGE." + (loop for name in (cons (package-name package) (package-nicknames package)) + for shortest = name then (if (< (length name) (length shortest)) + name + shortest) + finally (return shortest))) + +(defslimefun ed-in-emacs (&optional what) + "Edit WHAT in Emacs. + +WHAT can be: + 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 inspect-in-emacs (what) + "Inspect WHAT in Emacs." + (flet ((send-it () + (with-buffer-syntax () + (reset-inspector) + (send-oob-to-emacs `(:inspect ,(inspect-object what)))))) + (cond + (*emacs-connection* + (send-it)) + ((default-connection) + (with-connection ((default-connection)) + (send-it)))) + what)) + +(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." + ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005) + (with-buffer-syntax () + (prin1-to-string (eval (read-from-string form))))) + +(defslimefun commit-edited-value (form value) + "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)))) + 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 + +(defun swank-debugger-hook (condition hook) + "Debugger function for binding *DEBUGGER-HOOK*. +Sends a message to Emacs declaring that the debugger has been entered, +then waits to handle further requests from Emacs. Eventually returns +after Emacs causes a restart to be invoked." + (declare (ignore hook)) + (cond (*emacs-connection* + (debug-in-emacs condition)) + ((default-connection) + (with-connection ((default-connection)) + (debug-in-emacs condition))))) + +(defvar *global-debugger* t + "Non-nil means the Swank debugger hook will be installed globally.") + +(add-hook *new-connection-hook* 'install-debugger) +(defun install-debugger (connection) + (declare (ignore connection)) + (when *global-debugger* + (install-debugger-globally #'swank-debugger-hook))) + +;;;;; Debugger loop +;;; +;;; These variables are dynamically bound during debugging. +;;; +(defvar *swank-debugger-condition* nil + "The condition being debugged.") + +(defvar *sldb-level* 0 + "The current level of recursive debugging.") + +(defvar *sldb-initial-frames* 20 + "The initial number of backtrace frames to send to Emacs.") + +(defvar *sldb-restarts* nil + "The list of currenlty active restarts.") + +(defvar *sldb-stepping-p* nil + "True during execution of a step command.") + +(defun debug-in-emacs (condition) + (let ((*swank-debugger-condition* condition) + (*sldb-restarts* (compute-sane-restarts condition)) + (*package* (or (and (boundp '*buffer-package*) + (symbol-value '*buffer-package*)) + *package*)) + (*sldb-level* (1+ *sldb-level*)) + (*sldb-stepping-p* nil) + (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*))) + (force-user-output) + (call-with-debugging-environment + (lambda () + (with-bindings *sldb-printer-bindings* + (sldb-loop *sldb-level*)))))) + +(defun sldb-loop (level) + (unwind-protect + (catch 'sldb-enter-default-debugger + (send-to-emacs + (list* :debug (current-thread) level + (debugger-info-for-emacs 0 *sldb-initial-frames*))) + (loop (catch 'sldb-loop-catcher + (with-simple-restart (abort "Return to sldb level ~D." level) + (send-to-emacs (list :debug-activate (current-thread) + level)) + (handler-bind ((sldb-condition #'handle-sldb-condition)) + (read-from-emacs)))))) + (send-to-emacs `(:debug-return + ,(current-thread) ,level ,*sldb-stepping-p*)))) + +(defun handle-sldb-condition (condition) + "Handle an internal debugger condition. +Rather than recursively debug the debugger (a dangerous idea!), these +conditions are simply reported." + (let ((real-condition (original-condition condition))) + (send-to-emacs `(:debug-condition ,(current-thread) + ,(princ-to-string real-condition)))) + (throw 'sldb-loop-catcher nil)) + +(defun safe-condition-message (condition) + "Safely print condition to a string, handling any errors during +printing." + (let ((*print-pretty* t)) + (handler-case + (format-sldb-condition condition) + (error (cond) + ;; Beware of recursive errors in printing, so only use the condition + ;; if it is printable itself: + (format nil "Unable to display error condition~@[: ~A~]" + (ignore-errors (princ-to-string cond))))))) + +(defun debugger-condition-for-emacs () + (list (safe-condition-message *swank-debugger-condition*) + (format nil " [Condition of type ~S]" + (type-of *swank-debugger-condition*)) + (condition-extras *swank-debugger-condition*))) + +(defun format-restarts-for-emacs () + "Return a list of restarts for *swank-debugger-condition* in a +format suitable for Emacs." + (let ((*print-right-margin* most-positive-fixnum)) + (loop for restart in *sldb-restarts* + collect (list (princ-to-string (restart-name restart)) + (princ-to-string restart))))) + + +;;;;; SLDB entry points + +(defslimefun sldb-break-with-default-debugger () + "Invoke the default debugger by returning from our debugger-loop." + (throw 'sldb-enter-default-debugger nil)) + +(defslimefun backtrace (start end) + "Return a list ((I FRAME) ...) of frames from START to END. +I is an integer describing and FRAME a string." + (loop for frame in (compute-backtrace start end) + for i from start + collect (list i (with-output-to-string (stream) + (handler-case + (print-frame frame stream) + (t () + (format stream "[error printing frame]"))))))) + +(defslimefun debugger-info-for-emacs (start end) + "Return debugger state, with stack frames from START to END. +The result is a list: + (condition ({restart}*) ({stack-frame}*) (cont*)) +where + condition ::= (description type [extra]) + restart ::= (name description) + stack-frame ::= (number description) + extra ::= (:references and other random things) + cont ::= continutation +condition---a pair of strings: message, and type. If show-source is +not nil it is a frame number for which the source should be displayed. + +restart---a pair of strings: restart name, and description. + +stack-frame---a number from zero (the top), and a printed +representation of the frame's call. + +continutation---the id of a pending Emacs continuation. + +Below is an example return value. In this case the condition was a +division by zero (multi-line description), and only one frame is being +fetched (start=0, end=1). + + (("Arithmetic error DIVISION-BY-ZERO signalled. +Operation was KERNEL::DIVISION, operands (1 0)." + "[Condition of type DIVISION-BY-ZERO]") + (("ABORT" "Return to Slime toplevel.") + ("ABORT" "Return to Top-Level.")) + ((0 "(KERNEL::INTEGER-/-INTEGER 1 0)")) + (4))" + (list (debugger-condition-for-emacs) + (format-restarts-for-emacs) + (backtrace start end) + *pending-continuations*)) + +(defun nth-restart (index) + (nth index *sldb-restarts*)) + +(defslimefun invoke-nth-restart (index) + (invoke-restart-interactively (nth-restart index))) + +(defslimefun sldb-abort () + (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) + +(defslimefun sldb-continue () + (continue)) + +(defslimefun throw-to-toplevel () + "Invoke the ABORT-REQUEST restart abort an RPC from Emacs. +If we are not evaluating an RPC then ABORT instead." + (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. +SLDB-LEVEL is the debug level when the request was made. If this +has changed, ignore the request." + (when (= sldb-level *sldb-level*) + (invoke-nth-restart n))) + +(defun wrap-sldb-vars (form) + `(let ((*sldb-level* ,*sldb-level*)) + ,form)) + +(defslimefun eval-string-in-frame (string index) + (to-string (eval-in-frame (wrap-sldb-vars (from-string string)) + index))) + +(defslimefun pprint-eval-string-in-frame (string index) + (swank-pprint + (multiple-value-list + (eval-in-frame (wrap-sldb-vars (from-string string)) index)))) + +(defslimefun frame-locals-for-emacs (index) + "Return a property list ((&key NAME ID VALUE) ...) describing +the local variables in the frame INDEX." + (mapcar (lambda (frame-locals) + (destructuring-bind (&key name id value) frame-locals + (list :name (prin1-to-string name) :id id + :value (to-string value)))) + (frame-locals index))) + +(defslimefun frame-catch-tags-for-emacs (frame-index) + (mapcar #'to-string (frame-catch-tags frame-index))) + +(defslimefun sldb-disassemble (index) + (with-output-to-string (*standard-output*) + (disassemble-frame index))) + +(defslimefun sldb-return-from-frame (index string) + (let ((form (from-string string))) + (to-string (multiple-value-list (return-from-frame index form))))) + +(defslimefun sldb-break (name) + (with-buffer-syntax () + (sldb-break-at-start (read-from-string name)))) + +(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 "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. + +(defvar *compiler-notes* '() + "List of compiler notes for the last compilation unit.") + +(defun clear-compiler-notes () + (setf *compiler-notes* '())) + +(defun canonicalize-filename (filename) + (namestring (truename filename))) + +(defslimefun compiler-notes-for-emacs () + "Return the list of compiler notes for the last compilation unit." + (reverse *compiler-notes*)) + +(defun measure-time-interval (fn) + "Call FN and return the first return value and the elapsed time. +The time is measured in microseconds." + (declare (type function fn)) + (let ((before (get-internal-real-time))) + (values + (funcall fn) + (* (- (get-internal-real-time) before) + (/ 1000000 internal-time-units-per-second))))) + +(defun record-note-for-condition (condition) + "Record a note for a compiler-condition." + (push (make-compiler-note condition) *compiler-notes*)) + +(defun make-compiler-note (condition) + "Make a compiler note data structure from a compiler-condition." + (declare (type compiler-condition condition)) + (list* :message (message condition) + :severity (severity condition) + :location (location condition) + :references (references condition) + (let ((s (short-message condition))) + (if s (list :short-message s))))) + +(defun swank-compiler (function) + (clear-compiler-notes) + (multiple-value-bind (result usecs) + (with-simple-restart (abort "Abort SLIME compilation.") + (handler-bind ((compiler-condition #'record-note-for-condition)) + (measure-time-interval function))) + ;; WITH-SIMPLE-RESTART returns (values nil t) if its restart is invoked; + ;; unfortunately the SWANK protocol doesn't support returning multiple + ;; values, so we gotta convert it explicitely to a list in either case. + (if (and (not result) (eq usecs 't)) + (list nil nil) + (list (to-string result) + (format nil "~,2F" (/ usecs 1000000.0)))))) + +(defslimefun compile-file-for-emacs (filename load-p) + "Compile FILENAME and, when LOAD-P, load the result. +Record compiler notes signalled as `compiler-condition's." + (with-buffer-syntax () + (let ((*compile-print* nil)) + (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). +Record compiler notes signalled as `compiler-condition's." + (with-buffer-syntax () + (swank-compiler + (lambda () + (let ((*compile-print* nil) (*compile-verbose* t)) + (swank-compile-string string :buffer buffer :position position + :directory directory)))))) + +(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 requires-compile-p (source-file) + (let ((fasl-file (probe-file (compile-file-pathname source-file)))) + (or (not fasl-file) + (file-newer-p source-file fasl-file)))) + +(defslimefun compile-file-if-needed (filename loadp) + (cond ((requires-compile-p filename) + (compile-file-for-emacs filename loadp)) + (loadp + (load (compile-file-pathname filename)) + nil))) + + +;;;; Loading + +(defslimefun load-file (filename) + (to-string (load filename))) + +(defslimefun load-file-set-package (filename &optional package) + (load-file filename) + (if package + (set-package package))) + + +;;;;; swank-require + +(defslimefun swank-require (module &optional filename) + "Load the module MODULE." + (require module (or filename (module-filename module))) + nil) + +(defvar *find-module* 'find-module + "Pluggable function to locate modules. +The function receives a module name as argument and should return +the filename of the module (or nil if the file doesn't exist).") + +(defun module-filename (module) + "Return the filename for the module MODULE." + (or (funcall *find-module* module) + (error "Can't locate module: ~s" module))) + +;;;;;; Simple *find-module* function. + +(defun merged-directory (dirname defaults) + (pathname-directory + (merge-pathnames + (make-pathname :directory `(:relative ,dirname) :defaults defaults) + defaults))) + +(defvar *load-path* + (list (make-pathname :directory (merged-directory "contrib" *load-truename*) + :name nil :type nil :version nil + :defaults *load-truename*)) + "A list of directories to search for modules.") + +(defun module-canditates (name dir) + (list (compile-file-pathname (make-pathname :name name :defaults dir)) + (make-pathname :name name :type "lisp" :defaults dir))) + +(defun find-module (module) + (let ((name (string-downcase module))) + (some (lambda (dir) (some #'probe-file (module-canditates name dir))) + *load-path*))) + + +;;;; Macroexpansion + +(defvar *macroexpand-printer-bindings* + '((*print-circle* . nil) + (*print-pretty* . t) + (*print-escape* . t) + (*print-lines* . nil) + (*print-level* . nil) + (*print-length* . nil))) + +(defun apply-macro-expander (expander string) + (with-buffer-syntax () + (with-bindings *macroexpand-printer-bindings* + (prin1-to-string (funcall expander (from-string string)))))) + +(defslimefun swank-macroexpand-1 (string) + (apply-macro-expander #'macroexpand-1 string)) + +(defslimefun swank-macroexpand (string) + (apply-macro-expander #'macroexpand string)) + +(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*) + (let ((*print-readably* nil)) + (disassemble (fdefinition (from-string name))))))) + + +;;;; Simple completion + +(defslimefun simple-completions (string buffer-package) + "Return a list of completions for the string STRING." + (let ((strings (all-completions string buffer-package #'prefix-match-p))) + (list strings (longest-common-prefix strings)))) + +(defun all-completions (string buffer-package test) + (multiple-value-bind (name pname intern) (tokenize-symbol string) + (let* ((extern (and pname (not intern))) + (pack (cond ((equal pname "") keyword-package) + ((not pname) (guess-buffer-package buffer-package)) + (t (guess-package pname)))) + (test (lambda (sym) (funcall test name (unparse-symbol sym)))) + (syms (and pack (matching-symbols pack extern test)))) + (format-completion-set (mapcar #'unparse-symbol syms) intern pname)))) + +(defun matching-symbols (package external test) + (let ((test (if external + (lambda (s) + (and (symbol-external-p s package) + (funcall test s))) + test)) + (result '())) + (do-symbols (s package) + (when (funcall test s) + (push s result))) + (remove-duplicates result))) + +(defun unparse-symbol (symbol) + (let ((*print-case* (case (readtable-case *readtable*) + (:downcase :upcase) + (t :downcase)))) + (unparse-name (symbol-name symbol)))) + +(defun prefix-match-p (prefix string) + "Return true if PREFIX is a prefix of STRING." + (not (mismatch prefix string :end2 (min (length string) (length prefix))))) + +(defun longest-common-prefix (strings) + "Return the longest string that is a common prefix of STRINGS." + (if (null strings) + "" + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix strings)))) + +(defun format-completion-set (strings internal-p package-name) + "Format a set of completion strings. +Returns a list of completions with package qualifiers if needed." + (mapcar (lambda (string) (untokenize-symbol package-name internal-p string)) + (sort strings #'string<))) + + +;;;; Simple arglist display + +(defslimefun operator-arglist (name package) + (ignore-errors + (let ((args (arglist (parse-symbol name (guess-buffer-package package)))) + (*print-escape* nil)) + (cond ((eq args :not-available) nil) + (t (format nil "(~a ~/pprint-fill/)" name args)))))) + + +;;;; Documentation + +(defslimefun apropos-list-for-emacs (name &optional external-only + case-sensitive package) + "Make an apropos search for Emacs. +The result is a list of property lists." + (let ((package (if package + (or (parse-package package) + (error "No such package: ~S" package))))) + ;; The MAPCAN will filter all uninteresting symbols, i.e. those + ;; who cannot be meaningfully described. + (mapcan (listify #'briefly-describe-symbol-for-emacs) + (sort (remove-duplicates + (apropos-symbols name external-only case-sensitive package)) + #'present-symbol-before-p)))) + +(defun briefly-describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. +Like `describe-symbol-for-emacs' but with at most one line per item." + (flet ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos))))) + (let ((desc (map-if #'stringp #'first-line + (describe-symbol-for-emacs symbol)))) + (if desc + (list* :designator (to-string symbol) desc))))) + +(defun map-if (test fn &rest lists) + "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)" + (apply #'mapcar + (lambda (x) (if (funcall test x) (funcall fn x) x)) + lists)) + +(defun listify (f) + "Return a function like F, but which returns any non-null value +wrapped in a list." + (lambda (x) + (let ((y (funcall f x))) + (and y (list y))))) + +(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) + ;; 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) + (or (gethash regex-string regex-hash) + (setf (gethash regex-string regex-hash) + (if (zerop (length regex-string)) + (lambda (s) (check-type s string) t) + (compile nil (slime-nregex:regex-compile regex-string))))))) + +(defun make-regexp-matcher (string case-sensitive) + (let* ((case-modifier (if case-sensitive #'string #'string-upcase)) + (regex (compiled-regex (funcall case-modifier string)))) + (lambda (symbol) + (funcall regex (funcall case-modifier symbol))))) + +(defun apropos-symbols (string external-only case-sensitive package) + (let ((packages (or package (remove (find-package :keyword) + (list-all-packages)))) + (matcher (make-regexp-matcher string case-sensitive)) + (result)) + (with-package-iterator (next packages :external :internal) + (loop (multiple-value-bind (morep symbol) (next) + (cond ((not morep) (return)) + ((and (if external-only (symbol-external-p symbol) t) + (funcall matcher symbol)) + (push symbol result)))))) + result)) + +(defun call-with-describe-settings (fn) + (let ((*print-readably* nil)) + (funcall fn))) + +(defmacro with-describe-settings ((&rest _) &body body) + (declare (ignore _)) + `(call-with-describe-settings (lambda () ,@body))) + +(defun describe-to-string (object) + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe object)))) + +(defslimefun describe-symbol (symbol-name) + (with-buffer-syntax () + (describe-to-string (parse-symbol-or-lose symbol-name)))) + +(defslimefun describe-function (name) + (with-buffer-syntax () + (let ((symbol (parse-symbol-or-lose name))) + (describe-to-string (or (macro-function symbol) + (symbol-function symbol)))))) + +(defslimefun describe-definition-for-emacs (name kind) + (with-buffer-syntax () + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe-definition (parse-symbol-or-lose name) kind))))) + +(defslimefun documentation-symbol (symbol-name &optional default) + (with-buffer-syntax () + (multiple-value-bind (sym foundp) (parse-symbol symbol-name) + (if foundp + (let ((vdoc (documentation sym 'variable)) + (fdoc (documentation sym 'function))) + (or (and (or vdoc fdoc) + (concatenate 'string + fdoc + (and vdoc fdoc '(#\Newline #\Newline)) + vdoc)) + default)) + default)))) + + +;;;; Package Commands + +(defslimefun list-all-package-names (&optional nicknames) + "Return a list of all package names. +Include the nicknames if NICKNAMES is true." + (mapcar #'unparse-name + (if nicknames + (mapcan #'package-names (list-all-packages)) + (mapcar #'package-name (list-all-packages))))) + + +;;;; Tracing + +;; Use eval for the sake of portability... +(defun tracedp (fspec) + (member fspec (eval '(trace)))) + +(defslimefun swank-toggle-trace (spec-string) + (let ((spec (from-string spec-string))) + (cond ((consp spec) ; handle complicated cases in the backend + (toggle-trace spec)) + ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec)) + (format nil "~S is now traced." spec))))) + +(defslimefun untrace-all () + (untrace)) + +(defslimefun redirect-trace-output (target) + (setf (connection.trace-output *emacs-connection*) + (make-output-stream-for-target *emacs-connection* target)) + nil) + + +;;;; Undefing + +(defslimefun undefine-function (fname-string) + (let ((fname (from-string fname-string))) + (format nil "~S" (fmakunbound fname)))) + + +;;;; Profiling + +(defun profiledp (fspec) + (member fspec (profiled-functions))) + +(defslimefun toggle-profile-fdefinition (fname-string) + (let ((fname (from-string fname-string))) + (cond ((profiledp fname) + (unprofile fname) + (format nil "~S is now unprofiled." fname)) + (t + (profile fname) + (format nil "~S is now profiled." fname))))) + + +;;;; Source Locations + +(defslimefun find-definitions-for-emacs (name) + "Return a list ((DSPEC LOCATION) ...) of definitions for NAME. +DSPEC is a string and LOCATION a source location. NAME is a string." + (multiple-value-bind (sexp error) + (ignore-errors (values (from-string name))) + (unless error + (loop for (dspec loc) in (find-definitions sexp) + collect (list (to-string dspec) loc))))) + +(defun alistify (list key test) + "Partition the elements of LIST into an alist. KEY extracts the key +from an element and TEST is used to compare keys." + (declare (type function key)) + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (assoc k alist :test test))) + (if probe + (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) + (position-pos pos2))) + (t nil))) + +(defun partition (list test key) + (declare (type function test key)) + (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)))) + +(defstruct (xref (:conc-name xref.) + (:type list)) + dspec location) + +(defun location-valid-p (location) + (eq (car location) :location)) + +(defun xref-buffer (xref) + (location-buffer (xref.location xref))) + +(defun xref-position (xref) + (location-buffer (xref.location xref))) + +(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) + (partition xrefs #'location-valid-p #'xref.location) + (let ((alist (alistify resolved #'xref-buffer #'equal))) + (append + (loop for (buffer . list) in alist + collect (cons (second buffer) + (mapcar (lambda (xref) + (cons (to-string (xref.dspec xref)) + (xref.location xref))) + (sort list #'location-position< + :key #'xref-position)))) + (if errors + (list (cons "Unresolved" + (mapcar (lambda (xref) + (cons (to-string (xref.dspec xref)) + (xref.location xref))) + errors)))))))) + +(defslimefun xref (type symbol-name) + (let ((symbol (parse-symbol-or-lose symbol-name *buffer-package*))) + (group-xrefs + (ecase type + (:calls (who-calls symbol)) + (:calls-who (calls-who symbol)) + (:references (who-references symbol)) + (:binds (who-binds symbol)) + (:sets (who-sets symbol)) + (:macroexpands (who-macroexpands symbol)) + (:specializes (who-specializes symbol)) + (:callers (list-callers symbol)) + (:callees (list-callees symbol)))))) + + +;;;; Inspecting + +(defun common-seperated-spec (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast + (loop + for i in list + collect (funcall callback i) + collect ", "))) + +(defun inspector-princ (list) + "Like princ-to-string, but don't rewrite (function foo) as #'foo. +Do NOT pass circular lists to this function." + (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) + (set-pprint-dispatch '(cons (member function)) nil) + (princ-to-string list))) + +(defmethod inspect-for-emacs ((object cons) inspector) + (declare (ignore inspector)) + (if (consp (cdr object)) + (inspect-for-emacs-list object) + (inspect-for-emacs-simple-cons object))) + +(defun inspect-for-emacs-simple-cons (cons) + (values "A cons cell." + (label-value-line* + ('car (car cons)) + ('cdr (cdr cons))))) + +(defun inspect-for-emacs-list (list) + (let ((maxlen 40)) + (multiple-value-bind (length tail) (safe-length list) + (flet ((frob (title list) + (let (lines) + (loop for i from 0 for rest on list do + (if (consp (cdr rest)) ; e.g. (A . (B . ...)) + (push (label-value-line i (car rest)) lines) + (progn ; e.g. (A . NIL) or (A . B) + (push (label-value-line i (car rest) :newline nil) lines) + (when (cdr rest) + (push '((:newline)) lines) + (push (label-value-line ':tail () :newline nil) lines)) + (loop-finish))) + finally + (setf lines (reduce #'append (nreverse lines) :from-end t))) + (values title (append '("Elements:" (:newline)) lines))))) + + (cond ((not length) ; circular + (frob "A circular list." + (cons (car list) + (ldiff (cdr list) list)))) + ((and (<= length maxlen) (not tail)) + (frob "A proper list." list)) + (tail + (frob "An improper list." list)) + (t + (frob "A proper list." list))))))) + +;; (inspect-for-emacs-list '#1=(a #1# . #1# )) + +(defun safe-length (list) + "Similar to `list-length', but avoid errors on improper lists. +Return two values: the length of the list and the last cdr. +NIL is returned if the list is circular." + (do ((n 0 (+ n 2)) ;Counter. + (fast list (cddr fast)) ;Fast pointer: leaps by 2. + (slow list (cdr slow))) ;Slow pointer: leaps by 1. + (nil) + (cond ((null fast) (return (values n nil))) + ((not (consp fast)) (return (values n fast))) + ((null (cdr fast)) (return (values (1+ n) (cdr fast)))) + ((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 (prin1-to-string ht) + (append + (label-value-line* + ("Count" (hash-table-count ht)) + ("Size" (hash-table-size ht)) + ("Test" (hash-table-test ht)) + ("Rehash size" (hash-table-rehash-size ht)) + ("Rehash threshold" (hash-table-rehash-threshold ht))) + (let ((weakness (hash-table-weakness ht))) + (when weakness + `("Weakness: " (:value ,weakness) (:newline)))) + (unless (zerop (hash-table-count ht)) + `((:action "[clear hashtable]" ,(lambda () (clrhash ht))) (:newline) + "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 + repeat (or *slime-inspect-contents-limit* most-positive-fixnum) + append `((:value ,key) " = " (:value ,value) + " " (:action "[remove entry]" + ,(let ((key key)) + (lambda () (remhash key ht)))) + (:newline)))))) + +(defun 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)))) + +(defun inspect-whole-thing-action (thing size) + `(:action ,(format nil "Inspect all ~a elements." + size) + ,(lambda() + (let ((*slime-inspect-contents-limit* nil)) + (swank::inspect-object thing))))) + +(defun 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)))) + (swank::inspect-object thing))))) + +(defmethod inspect-for-emacs ((array array) inspector) + (declare (ignore inspector)) + (values "An array." + (append + (label-value-line* + ("Dimensions" (array-dimensions array)) + ("Its element type is" (array-element-type array)) + ("Total size" (array-total-size array)) + ("Adjustable" (adjustable-array-p array))) + (when (array-has-fill-pointer-p array) + (label-value-line "Fill pointer" (fill-pointer array))) + '("Contents:" (:newline)) + (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) + (declare (ignore inspector)) + (values "A character." + (append + (label-value-line* + ("Char code" (char-code char)) + ("Lower cased" (char-downcase char)) + ("Upper cased" (char-upcase char))) + (if (get-macro-character char) + `("In the current readtable (" + (:value ,*readtable*) ") it is a macro character: " + (:value ,(get-macro-character char))))))) + +(defvar *inspectee*) +(defvar *inspectee-parts*) +(defvar *inspectee-actions*) +(defvar *inspector-stack* '()) +(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)) +(declaim (type vector *inspector-history*)) +(defvar *inspect-length* 30) +(defvar *default-inspector* (make-default-inspector)) + +(defun reset-inspector () + (setq *inspectee* nil + *inspector-stack* nil + *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0) + *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0) + *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) + +;; FIXME: Unused? +(defun valid-function-name-p (form) + (or (and (not (null form)) + (not (eq form t)) + (symbolp form)) + (and (consp form) + (second form) + (not (third form)) + (eq (first form) 'setf)))) + +(defslimefun init-inspector (string) + (with-buffer-syntax () + (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*))) + (if pos + (format nil "#~D=~A" pos string) + string))) + +(defun inspector-content-for-emacs (specs) + (loop for part in specs collect + (etypecase part + (null ; XXX encourages sloppy programming + nil) + (string part) + (cons (destructure-case part + ((:newline) + (string #\newline)) + ((:value obj &optional str) + (value-part-for-emacs obj str)) + ((:action label lambda &key (refreshp t)) + (action-part-for-emacs label lambda refreshp))))))) + +(defun assign-index (object vector) + (let ((index (fill-pointer vector))) + (vector-push-extend object vector) + index)) + +(defun value-part-for-emacs (object string) + (list :value + (or string (print-part-to-string object)) + (assign-index object *inspectee-parts*))) + +(defun action-part-for-emacs (label lambda refreshp) + (list :action label (assign-index (list lambda refreshp) + *inspectee-actions*))) + +(defun inspect-object (object &optional (inspector *default-inspector*)) + (push (setq *inspectee* object) *inspector-stack*) + (unless (find object *inspector-history*) + (vector-push-extend object *inspector-history*)) + (let ((*print-pretty* nil) ; print everything in the same line + (*print-circle* t) + (*print-readably* nil)) + (multiple-value-bind (title content) (inspect-for-emacs object inspector) + (list :title title + :type (to-string (type-of object)) + :content (inspector-content-for-emacs content))))) + +(defslimefun inspector-nth-part (index) + (aref *inspectee-parts* index)) + +(defslimefun inspect-nth-part (index) + (with-buffer-syntax () + (inspect-object (inspector-nth-part index)))) + +(defslimefun inspector-call-nth-action (index &rest args) + (destructuring-bind (action-lambda refreshp) + (aref *inspectee-actions* index) + (apply action-lambda args) + (if refreshp + (inspect-object (pop *inspector-stack*)) + ;; tell emacs that we don't want to refresh the inspector buffer + nil))) + +(defslimefun inspector-pop () + "Drop the inspector stack and inspect the second element. Return +nil if there's no second element." + (with-buffer-syntax () + (cond ((cdr *inspector-stack*) + (pop *inspector-stack*) + (inspect-object (pop *inspector-stack*))) + (t nil)))) + +(defslimefun inspector-next () + "Inspect the next element in the *inspector-history*." + (with-buffer-syntax () + (let ((position (position *inspectee* *inspector-history*))) + (cond ((= (1+ position) (length *inspector-history*)) + nil) + (t (inspect-object (aref *inspector-history* (1+ position)))))))) + +(defslimefun inspector-reinspect () + (inspect-object *inspectee*)) + +(defslimefun quit-inspector () + (reset-inspector) + nil) + +(defslimefun describe-inspectee () + "Describe the currently inspected object." + (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) + (inspect-object (eval-in-frame (from-string string) index)))) + +(defslimefun inspect-current-condition () + (with-buffer-syntax () + (reset-inspector) + (inspect-object *swank-debugger-condition*))) + +(defslimefun inspect-frame-var (frame var) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (frame-var-value frame var)))) + + +;;;; Thread listing + +(defvar *thread-list* () + "List of threads displayed in Emacs. We don't care a about +synchronization issues (yet). There can only be one thread listing at +a time.") + +(defslimefun list-threads () + "Return a list ((NAME DESCRIPTION) ...) of all threads." + (setq *thread-list* (all-threads)) + (loop for thread in *thread-list* + for name = (thread-name thread) + collect (list (if (symbolp name) (symbol-name name) name) + (thread-status thread) + (thread-id thread)))) + +(defslimefun quit-thread-browser () + (setq *thread-list* nil)) + +(defun nth-thread (index) + (nth index *thread-list*)) + +(defslimefun debug-nth-thread (index) + (let ((connection *emacs-connection*)) + (interrupt-thread (nth-thread index) + (lambda () + (with-connection (connection) + (simple-break)))))) + +(defslimefun kill-nth-thread (index) + (kill-thread (nth-thread index))) + +(defslimefun start-swank-server-in-thread (index port-file-name) + "Interrupt the INDEXth thread and make it start a swank server. +The server port is written to PORT-FILE-NAME." + (interrupt-thread (nth-thread index) + (lambda () + (start-server port-file-name :style nil)))) + +;;;; Class browser + +(defun mop-helper (class-name fn) + (let ((class (find-class class-name nil))) + (if class + (mapcar (lambda (x) (to-string (class-name x))) + (funcall fn class))))) + +(defslimefun mop (type symbol-name) + "Return info about classes using mop. + + When type is: + :subclasses - return the list of subclasses of class. + :superclasses - return the list of superclasses of class." + (let ((symbol (parse-symbol symbol-name *buffer-package*))) + (ecase type + (:subclasses + (mop-helper symbol #'swank-mop:class-direct-subclasses)) + (:superclasses + (mop-helper symbol #'swank-mop:class-direct-superclasses))))) + + +;;;; Automatically synchronized state +;;; +;;; Here we add hooks to push updates of relevant information to +;;; Emacs. + +;;;;; *FEATURES* + +(defun sync-features-to-emacs () + "Update Emacs if any relevant Lisp state has changed." + ;; FIXME: *slime-features* should be connection-local + (unless (eq *slime-features* *features*) + (setq *slime-features* *features*) + (send-to-emacs (list :new-features (features-for-emacs))))) + +(defun features-for-emacs () + "Return `*slime-features*' in a format suitable to send it to Emacs." + *slime-features*) + +(add-hook *pre-reply-hook* 'sync-features-to-emacs) + + +;;;;; Indentation of macros +;;; +;;; This code decides how macros should be indented (based on their +;;; arglists) and tells Emacs. A per-connection cache is used to avoid +;;; sending redundant information to Emacs -- we just say what's +;;; changed since last time. +;;; +;;; The strategy is to scan all symbols, pick out the macros, and look +;;; for &body-arguments. + +(defvar *configure-emacs-indentation* t + "When true, automatically send indentation information to Emacs +after each command.") + +(defslimefun update-indentation-information () + (perform-indentation-update *emacs-connection* t) + nil) + +;; This function is for *PRE-REPLY-HOOK*. +(defun sync-indentation-to-emacs () + "Send any indentation updates to Emacs via CONNECTION." + (when *configure-emacs-indentation* + (let ((fullp (need-full-indentation-update-p *emacs-connection*))) + (perform-indentation-update *emacs-connection* fullp)))) + +(defun need-full-indentation-update-p (connection) + "Return true if the whole indentation cache should be updated. +This is a heuristic to avoid scanning all symbols all the time: +instead, we only do a full scan if the set of packages has changed." + (set-difference (list-all-packages) + (connection.indentation-cache-packages connection))) + +(defun perform-indentation-update (connection force) + "Update the indentation cache in CONNECTION and update Emacs. +If FORCE is true then start again without considering the old cache." + (let ((cache (connection.indentation-cache connection))) + (when force (clrhash cache)) + (let ((delta (update-indentation/delta-for-emacs cache force))) + (setf (connection.indentation-cache-packages connection) + (list-all-packages)) + (unless (null delta) + (send-to-emacs (list :indentation-update delta)))))) + +(defun update-indentation/delta-for-emacs (cache &optional force) + "Update the cache and return the changes in a (SYMBOL . INDENT) list. +If FORCE is true then check all symbols, otherwise only check symbols +belonging to the buffer package." + (let ((alist '())) + (flet ((consider (symbol) + (let ((indent (symbol-indentation symbol))) + (when indent + (unless (equal (gethash symbol cache) indent) + (setf (gethash symbol cache) indent) + (push (cons (string-downcase symbol) indent) alist)))))) + (if force + (do-all-symbols (symbol) + (consider symbol)) + (do-symbols (symbol *buffer-package*) + ;; We're really just interested in the symbols of *BUFFER-PACKAGE*, + ;; and *not* all symbols that are _present_ (cf. SYMBOL-STATUS.) + (when (eq (symbol-package symbol) *buffer-package*) + (consider symbol))))) + alist)) + +(defun package-names (package) + "Return the name and all nicknames of PACKAGE in a fresh list." + (cons (package-name package) (copy-list (package-nicknames package)))) + +(defun cl-symbol-p (symbol) + "Is SYMBOL a symbol in the COMMON-LISP package?" + (eq (symbol-package symbol) cl-package)) + +(defun known-to-emacs-p (symbol) + "Return true if Emacs has special rules for indenting SYMBOL." + (cl-symbol-p symbol)) + +(defun symbol-indentation (symbol) + "Return a form describing the indentation of SYMBOL. +The form is to be used as the `common-lisp-indent-function' property +in Emacs." + (if (and (macro-function symbol) + (not (known-to-emacs-p symbol))) + (let ((arglist (arglist symbol))) + (etypecase arglist + ((member :not-available) + nil) + (list + (macro-indentation arglist)))) + nil)) + +(defun macro-indentation (arglist) + (if (well-formed-list-p arglist) + (position '&body (remove '&optional (clean-arglist arglist))) + nil)) + +(defun clean-arglist (arglist) + "Remove &whole, &enviroment, and &aux elements from ARGLIST." + (cond ((null arglist) '()) + ((member (car arglist) '(&whole &environment)) + (clean-arglist (cddr arglist))) + ((eq (car arglist) '&aux) + '()) + (t (cons (car arglist) (clean-arglist (cdr arglist)))))) + +(defun well-formed-list-p (list) + "Is LIST a proper list terminated by NIL?" + (typecase list + (null t) + (cons (well-formed-list-p (cdr list))) + (t nil))) + +(defun print-indentation-lossage (&optional (stream *standard-output*)) + "Return the list of symbols whose indentation styles collide incompatibly. +Collisions are caused because package information is ignored." + (let ((table (make-hash-table :test 'equal))) + (flet ((name (s) (string-downcase (symbol-name s)))) + (do-all-symbols (s) + (setf (gethash (name s) table) + (cons s (symbol-indentation s)))) + (let ((collisions '())) + (do-all-symbols (s) + (let* ((entry (gethash (name s) table)) + (owner (car entry)) + (indent (cdr entry))) + (unless (or (eq s owner) + (equal (symbol-indentation s) indent) + (and (not (fboundp s)) + (null (macro-function s)))) + (pushnew owner collisions) + (pushnew s collisions)))) + (if (null collisions) + (format stream "~&No worries!~%") + (format stream "~&Symbols with collisions:~%~{ ~S~%~}" + collisions)))))) + +(add-hook *pre-reply-hook* 'sync-indentation-to-emacs) + +;;; swank.lisp ends here
Added: branches/trunk-reorg/thirdparty/slime/test-all.sh =================================================================== --- branches/trunk-reorg/thirdparty/slime/test-all.sh 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/test-all.sh 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,14 @@ +#!/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 + for lisp in 'cmucl -noinit' sbcl lispworks-personal-4300 'clisp -K full' acl5; do + echo testing: $emacs $lisp dribble.$emacs_$lisp result.$emacs_$lisp + test.sh $emacs "$lisp" "dribble.${emacs}_${lisp}" "result.${emacs}_${lisp}" + done +done + \ No newline at end of file
Property changes on: branches/trunk-reorg/thirdparty/slime/test-all.sh ___________________________________________________________________ Name: svn:executable + *
Added: branches/trunk-reorg/thirdparty/slime/test.sh =================================================================== --- branches/trunk-reorg/thirdparty/slime/test.sh 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/test.sh 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,82 @@ +#!/bin/sh + +# 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 +# one-line summary is printed. + +# If something unexpected fails, you might get an exit code like 127 +# or 255 instead. Sorry. + +# This code has been placed in the Public Domain. All warranties +# are disclaimed. + +function usage () { + echo "Usage: $name [-v] [-r] <emacs> <lisp>" + exit 1 +} + +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 -r $slimedir/*.{el,lisp} ChangeLog $slimedir/contrib $testdir +mkfifo $dribble + +session=slime-screen.$$ + +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" & + +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
Property changes on: branches/trunk-reorg/thirdparty/slime/test.sh ___________________________________________________________________ Name: svn:executable + *
Added: branches/trunk-reorg/thirdparty/slime/xref.lisp =================================================================== --- branches/trunk-reorg/thirdparty/slime/xref.lisp 2007-10-04 17:22:27 UTC (rev 2199) +++ branches/trunk-reorg/thirdparty/slime/xref.lisp 2007-10-04 17:23:45 UTC (rev 2200) @@ -0,0 +1,2891 @@ +;;; -*- Mode: LISP; Package: XREF; Syntax: Common-lisp; -*- +;;; Mon Jan 21 16:21:20 1991 by Mark Kantrowitz mkant@GLINDA.OZ.CS.CMU.EDU +;;; xref.lisp + +;;; **************************************************************** +;;; List Callers: A Static Analysis Cross Referencing Tool for Lisp +;;; **************************************************************** +;;; +;;; The List Callers system is a portable Common Lisp cross referencing +;;; utility. It grovels over a set of files and compiles a database of the +;;; locations of all references for each symbol used in the files. +;;; List Callers is similar to the Symbolics Who-Calls and the +;;; Xerox Masterscope facilities. +;;; +;;; When you change a function or variable definition, it can be useful +;;; to know its callers, in order to update each of them to the new +;;; definition. Similarly, having a graphic display of the structure +;;; (e.g., call graph) of a program can help make undocumented code more +;;; understandable. This static code analyzer facilitates both capabilities. +;;; The database compiled by xref is suitable for viewing by a graphical +;;; browser. (Note: the reference graph is not necessarily a DAG. Since many +;;; graphical browsers assume a DAG, this will lead to infinite loops. +;;; Some code which is useful in working around this problem is included, +;;; as well as a sample text-indenting outliner and an interface to Bates' +;;; PSGraph Postscript Graphing facility.) +;;; +;;; Written by Mark Kantrowitz, July 1990. +;;; +;;; Address: School of Computer Science +;;; Carnegie Mellon University +;;; Pittsburgh, PA 15213 +;;; +;;; Copyright (c) 1990. All rights reserved. +;;; +;;; See general license below. +;;; + +;;; **************************************************************** +;;; General License Agreement and Lack of Warranty ***************** +;;; **************************************************************** +;;; +;;; This software is distributed in the hope that it will be useful (both +;;; in and of itself and as an example of lisp programming), but WITHOUT +;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for +;;; the consequences of using it or for whether it serves any particular +;;; purpose or works at all. No warranty is made about the software or its +;;; performance. +;;; +;;; Use and copying of this software and the preparation of derivative +;;; works based on this software are permitted, so long as the following +;;; conditions are met: +;;; o The copyright notice and this entire notice are included intact +;;; and prominently carried on all copies and supporting documentation. +;;; o No fees or compensation are charged for use, copies, or +;;; access to this software. You may charge a nominal +;;; distribution fee for the physical act of transferring a +;;; copy, but you may not charge for the program itself. +;;; o If you modify this software, you must cause the modified +;;; file(s) to carry prominent notices (a Change Log) +;;; describing the changes, who made the changes, and the date +;;; of those changes. +;;; o Any work distributed or published that in whole or in part +;;; contains or is a derivative of this software or any part +;;; thereof is subject to the terms of this agreement. The +;;; aggregation of another unrelated program with this software +;;; or its derivative on a volume of storage or distribution +;;; medium does not bring the other program under the scope +;;; of these terms. +;;; o Permission is granted to manufacturers and distributors of +;;; lisp compilers and interpreters to include this software +;;; with their distribution. +;;; +;;; This software is made available AS IS, and is distributed without +;;; warranty of any kind, either expressed or implied. +;;; +;;; In no event will the author(s) or their institutions be liable to you +;;; for damages, including lost profits, lost monies, or other special, +;;; incidental or consequential damages arising out of or in connection +;;; with the use or inability to use (including but not limited to loss of +;;; data or data being rendered inaccurate or losses sustained by third +;;; parties or a failure of the program to operate as documented) the +;;; program, even if you have been advised of the possibility of such +;;; damanges, or for any claim by any other party, whether in an action of +;;; contract, negligence, or other tortious action. +;;; +;;; The current version of this software and a variety of related utilities +;;; may be obtained by anonymous ftp from ftp.cs.cmu.edu in the directory +;;; user/ai/lang/lisp/code/tools/xref/ +;;; +;;; Please send bug reports, comments, questions and suggestions to +;;; mkant@cs.cmu.edu. We would also appreciate receiving any changes +;;; or improvements you may make. +;;; +;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list, +;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email +;;; address, and affiliation. This mailing list is primarily for +;;; notification about major updates, bug fixes, and additions to the lisp +;;; utilities collection. The mailing list is intended to have low traffic. +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 27-FEB-91 mk Added insert arg to psgraph-xref to allow the postscript +;;; graphs to be inserted in Scribe documents. +;;; 21-FEB-91 mk Added warning if not compiled. +;;; 07-FEB-91 mk Fixed bug in record-callers with regard to forms at +;;; toplevel. +;;; 21-JAN-91 mk Added file xref-test.lisp to test xref. +;;; 16-JAN-91 mk Added definition WHO-CALLS to parallel the Symbolics syntax. +;;; 16-JAN-91 mk Added macroexpansion capability to record-callers. Also +;;; added parameter *handle-macro-forms*, defaulting to T. +;;; 16-JAN-91 mk Modified print-caller-tree and related functions +;;; to allow the user to specify root nodes. If the user +;;; doesn't specify them, it will default to all root +;;; nodes, as before. +;;; 16-JAN-91 mk Added parameter *default-graphing-mode* to specify +;;; the direction of the graphing. Either :call-graph, +;;; where the children of a node are those functions called +;;; by the node, or :caller-graph where the children of a +;;; node are the callers of the node. :call-graph is the +;;; default. +;;; 16-JAN-91 mk Added parameter *indent-amount* to control the indentation +;;; in print-indented-tree. +;;; 16-JUL-90 mk Functions with argument lists of () were being ignored +;;; because of a (when form) wrapped around the body of +;;; record-callers. Then intent of (when form) was as an extra +;;; safeguard against infinite looping. This wasn't really +;;; necessary, so it has been removed. +;;; 16-JUL-90 mk PSGraph-XREF now has keyword arguments, instead of +;;; optionals. +;;; 16-JUL-90 mk Added PRINT-CLASS-HIERARCHY to use psgraph to graph the +;;; CLOS class hierarchy. This really doesn't belong here, +;;; and should be moved to psgraph.lisp as an example of how +;;; to use psgraph. +;;; 16-JUL-90 mk Fixed several caller patterns. The pattern for member +;;; had an error which caused many references to be missed. +;;; 16-JUL-90 mk Added ability to save/load processed databases. +;;; 5-JUL-91 mk Fixed warning of needing compilation to occur only when the +;;; source is loaded. +;;; 20-SEP-93 mk Added fix from Peter Norvig to allow Xref to xref itself. +;;; The arg to macro-function must be a symbol. + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; Verify that: +;;; o null forms don't cause it to infinite loop. +;;; o nil matches against null argument lists. +;;; o declarations and doc are being ignored. +;;; +;;; Would be nice if in addition to showing callers of a function, it +;;; displayed the context of the calls to the function (e.g., the +;;; immediately surrounding form). This entails storing entries of +;;; the form (symbol context*) in the database and augmenting +;;; record-callers to keep the context around. The only drawbacks is +;;; that it would cons a fair bit. If we do this, we should store +;;; additional information as well in the database, such as the caller +;;; pattern type (e.g., variable vs. function). +;;; +;;; Write a translator from BNF (at least as much of BNF as is used +;;; in CLtL2), to the format used here. +;;; +;;; Should automatically add new patterns for new functions and macros +;;; based on their arglists. Probably requires much more than this +;;; simple code walker, so there isn't much we can do. +;;; +;;; Defmacro is a problem, because it often hides internal function +;;; calls within backquote and quote, which we normally ignore. If +;;; we redefine QUOTE's pattern so that it treats the arg like a FORM, +;;; we'll probably get them (though maybe the syntax will be mangled), +;;; but most likely a lot of spurious things as well. +;;; +;;; Define an operation for Defsystem which will run XREF-FILE on the +;;; files of the system. Or yet simpler, when XREF sees a LOAD form +;;; for which the argument is a string, tries to recursively call +;;; XREF-FILE on the specified file. Then one could just XREF-FILE +;;; the file which loads the system. (This should be a program +;;; parameter.) +;;; +;;; Have special keywords which the user may place in a file to have +;;; XREF-FILE ignore a region. +;;; +;;; Should we distinguish flet and labels from defun? I.e., note that +;;; flet's definitions are locally defined, instead of just lumping +;;; them in with regular definitions. +;;; +;;; Add patterns for series, loop macro. +;;; +;;; Need to integrate the variable reference database with the other +;;; databases, yet maintain separation. So we can distinguish all +;;; the different types of variable and function references, without +;;; multiplying databases. +;;; +;;; Would pay to comment record-callers and record-callers* in more +;;; depth. +;;; +;;; (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT) + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; XREF has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90) +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; +;;; XREF has been tested (unsuccessfully) in the following lisps: +;;; Ibuki Common Lisp (01/01, October 15, 1987) +;;; - if interpreted, runs into stack overflow +;;; - does not compile (tried ibcl on Suns, PMAXes and RTs) +;;; seems to be due to a limitation in the c compiler. +;;; +;;; XREF needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; Lucid Common Lisp (3.0, 4.0) +;;; KCL (June 3, 1987 or later) +;;; AKCL (1.86, June 30, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; HP Common Lisp (same as Lucid?) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; XREF analyzes a user's program, determining which functions call a +;;; given function, and the location of where variables are bound/assigned +;;; and used. The user may retrieve this information for either a single +;;; symbol, or display the call graph of portions of the program +;;; (including the entire program). This allows the programmer to debug +;;; and document the program's structure. +;;; +;;; XREF is primarily intended for analyzing large programs, where it is +;;; difficult, if not impossible, for the programmer to grasp the structure +;;; of the whole program. Nothing precludes using XREF for smaller programs, +;;; where it can be useful for inspecting the relationships between pieces +;;; of the program and for documenting the program. +;;; +;;; Two aspects of the Lisp programming language greatly simplify the +;;; analysis of Lisp programs: +;;; o Lisp programs are naturally represented as data. +;;; Successive definitions from a file are easily read in +;;; as list structure. +;;; o The basic syntax of Lisp is uniform. A list program +;;; consists of a set of nested forms, where each form is +;;; a list whose car is a tag (e.g., function name) that +;;; specifies the structure of the rest of the form. +;;; Thus Lisp programs, when represented as data, can be considered to be +;;; parse trees. Given a grammar of syntax patterns for the language, XREF +;;; recursively descends the parse tree for a given definition, computing +;;; a set of relations that hold for the definition at each node in the +;;; tree. For example, one kind of relation is that the function defined +;;; by the definition calls the functions in its body. The relations are +;;; stored in a database for later examination by the user. +;;; +;;; While XREF currently only works for programs written in Lisp, it could +;;; be extended to other programming languages by writing a function to +;;; generate parse trees for definitions in that language, and a core +;;; set of patterns for the language's syntax. +;;; +;;; Since XREF normally does a static syntactic analysis of the program, +;;; it does not detect references due to the expansion of a macro definition. +;;; To do this in full generality XREF would have to have knowledge about the +;;; semantics of the program (e.g., macros which call other functions to +;;; do the expansion). This entails either modifying the compiler to +;;; record the relationships (e.g., Symbolics Who-Calls Database) or doing +;;; a walk of loaded code and macroexpanding as needed (PCL code walker). +;;; The former is not portable, while the latter requires that the code +;;; used by macros be loaded and in working order. On the other hand, then +;;; we would need no special knowledge about macros (excluding the 24 special +;;; forms of Lisp). +;;; +;;; Parameters may be set to enable macro expansion in XREF. Then XREF +;;; will expand any macros for which it does not have predefined patterns. +;;; (For example, most Lisps will implement dolist as a macro. Since XREF +;;; has a pattern defined for dolist, it will not call macroexpand-1 on +;;; a form whose car is dolist.) For this to work properly, the code must +;;; be loaded before being processed by XREF, and XREF's parameters should +;;; be set so that it processes forms in their proper packages. +;;; +;;; If macro expansion is disabled, the default rules for handling macro +;;; references may not be sufficient for some user-defined macros, because +;;; macros allow a variety of non-standard syntactic extensions to the +;;; language. In this case, the user may specify additional templates in +;;; a manner similar to that in which the core Lisp grammar was specified. +;;; + + +;;; ******************************** +;;; User Guide ********************* +;;; ******************************** +;;; ----- +;;; The following functions are called to cross reference the source files. +;;; +;;; XREF-FILES (&rest files) [FUNCTION] +;;; Grovels over the lisp code located in source file FILES, using +;;; xref-file. +;;; +;;; XREF-FILE (filename &optional clear-tables verbose) [Function] +;;; Cross references the function and variable calls in FILENAME by +;;; walking over the source code located in the file. Defaults type of +;;; filename to ".lisp". Chomps on the code using record-callers and +;;; record-callers*. If CLEAR-TABLES is T (the default), it clears the +;;; callers database before processing the file. Specify CLEAR-TABLES as +;;; nil to append to the database. If VERBOSE is T (the default), prints +;;; out the name of the file, one progress dot for each form processed, +;;; and the total number of forms. +;;; +;;; ----- +;;; The following functions display information about the uses of the +;;; specified symbol as a function, variable, or constant. +;;; +;;; LIST-CALLERS (symbol) [FUNCTION] +;;; Lists all functions which call SYMBOL as a function (function +;;; invocation). +;;; +;;; LIST-READERS (symbol) [FUNCTION] +;;; Lists all functions which refer to SYMBOL as a variable +;;; (variable reference). +;;; +;;; LIST-SETTERS (symbol) [FUNCTION] +;;; Lists all functions which bind/set SYMBOL as a variable +;;; (variable mutation). +;;; +;;; LIST-USERS (symbol) [FUNCTION] +;;; Lists all functions which use SYMBOL as a variable or function. +;;; +;;; WHO-CALLS (symbol &optional how) [FUNCTION] +;;; Lists callers of symbol. HOW may be :function, :reader, :setter, +;;; or :variable." +;;; +;;; WHAT-FILES-CALL (symbol) [FUNCTION] +;;; Lists names of files that contain uses of SYMBOL +;;; as a function, variable, or constant. +;;; +;;; SOURCE-FILE (symbol) [FUNCTION] +;;; Lists the names of files in which SYMBOL is defined/used. +;;; +;;; LIST-CALLEES (symbol) [FUNCTION] +;;; Lists names of functions and variables called by SYMBOL. +;;; +;;; ----- +;;; The following functions may be useful for viewing the database and +;;; debugging the calling patterns. +;;; +;;; *LAST-FORM* () [VARIABLE] +;;; The last form read from the file. Useful for figuring out what went +;;; wrong when xref-file drops into the debugger. +;;; +;;; *XREF-VERBOSE* t [VARIABLE] +;;; When T, xref-file(s) prints out the names of the files it looks at, +;;; progress dots, and the number of forms read. +;;; +;;; *TYPES-TO-IGNORE* (quote (:lisp :lisp2)) [VARIABLE] +;;; Default set of caller types (as specified in the patterns) to ignore +;;; in the database handling functions. :lisp is CLtL 1st edition, +;;; :lisp2 is additional patterns from CLtL 2nd edition. +;;; +;;; *HANDLE-PACKAGE-FORMS* () [VARIABLE] +;;; When non-NIL, and XREF-FILE sees a package-setting form like +;;; IN-PACKAGE, sets the current package to the specified package by +;;; evaluating the form. When done with the file, xref-file resets the +;;; package to its original value. In some of the displaying functions, +;;; when this variable is non-NIL one may specify that all symbols from a +;;; particular set of packages be ignored. This is only useful if the +;;; files use different packages with conflicting names. +;;; +;;; *HANDLE-FUNCTION-FORMS* t [VARIABLE] +;;; When T, XREF-FILE tries to be smart about forms which occur in +;;; a function position, such as lambdas and arbitrary Lisp forms. +;;; If so, it recursively calls record-callers with pattern 'FORM. +;;; If the form is a lambda, makes the caller a caller of +;;; :unnamed-lambda. +;;; +;;; *HANDLE-MACRO-FORMS* t [VARIABLE] +;;; When T, if the file was loaded before being processed by XREF, and +;;; the car of a form is a macro, it notes that the parent calls the +;;; macro, and then calls macroexpand-1 on the form. +;;; +;;; *DEFAULT-GRAPHING-MODE* :call-graph [VARIABLE] +;;; Specifies whether we graph up or down. If :call-graph, the children +;;; of a node are the functions it calls. If :caller-graph, the +;;; children of a node are the functions that call it. +;;; +;;; *INDENT-AMOUNT* 3 [VARIABLE] +;;; Number of spaces to indent successive levels in PRINT-INDENTED-TREE. +;;; +;;; DISPLAY-DATABASE (&optional database types-to-ignore) [FUNCTION] +;;; Prints out the name of each symbol and all its callers. Specify +;;; database :callers (the default) to get function call references, +;;; :file to the get files in which the symbol is called, :readers to get +;;; variable references, and :setters to get variable binding and +;;; assignments. Ignores functions of types listed in types-to-ignore. +;;; +;;; PRINT-CALLER-TREES (&key (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact root-nodes) +;;; Prints the calling trees (which may actually be a full graph and not +;;; necessarily a DAG) as indented text trees using +;;; PRINT-INDENTED-TREE. MODE is :call-graph for trees where the children +;;; of a node are the functions called by the node, or :caller-graph for +;;; trees where the children of a node are the functions the node calls. +;;; TYPES-TO-IGNORE is a list of funcall types (as specified in the +;;; patterns) to ignore in printing out the database. For example, +;;; '(:lisp) would ignore all calls to common lisp functions. COMPACT is +;;; a flag to tell the program to try to compact the trees a bit by not +;;; printing trees if they have already been seen. ROOT-NODES is a list +;;; of root nodes of trees to display. If ROOT-NODES is nil, tries to +;;; find all root nodes in the database. +;;; +;;; MAKE-CALLER-TREE (&optional (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact) +;;; Outputs list structure of a tree which roughly represents the +;;; possibly cyclical structure of the caller database. +;;; If mode is :call-graph, the children of a node are the functions +;;; it calls. If mode is :caller-graph, the children of a node are the +;;; functions that call it. +;;; If compact is T, tries to eliminate the already-seen nodes, so +;;; that the graph for a node is printed at most once. Otherwise it will +;;; duplicate the node's tree (except for cycles). This is usefull +;;; because the call tree is actually a directed graph, so we can either +;;; duplicate references or display only the first one. +;;; +;;; DETERMINE-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Makes a hash table of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically resolving +;;; file references for automatic creation of a system definition +;;; (defsystem). +;;; +;;; PRINT-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Prints a list of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically computing +;;; file loading constraints for a system definition tool. +;;; +;;; WRITE-CALLERS-DATABASE-TO-FILE (filename) [FUNCTION] +;;; Saves the contents of the current callers database to a file. This +;;; file can be loaded to restore the previous contents of the +;;; database. (For large systems it can take a long time to crunch +;;; through the code, so this can save some time.) +;;; +;;; ----- +;;; The following macros define new function and macro call patterns. +;;; They may be used to extend the static analysis tool to handle +;;; new def forms, extensions to Common Lisp, and program defs. +;;; +;;; DEFINE-PATTERN-SUBSTITUTION (name pattern) [MACRO] +;;; Defines NAME to be equivalent to the specified pattern. Useful for +;;; making patterns more readable. For example, the LAMBDA-LIST is +;;; defined as a pattern substitution, making the definition of the +;;; DEFUN caller-pattern simpler. +;;; +;;; DEFINE-CALLER-PATTERN (name pattern &optional caller-type) [MACRO] +;;; Defines NAME as a function/macro call with argument structure +;;; described by PATTERN. CALLER-TYPE, if specified, assigns a type to +;;; the pattern, which may be used to exclude references to NAME while +;;; viewing the database. For example, all the Common Lisp definitions +;;; have a caller-type of :lisp or :lisp2, so that you can exclude +;;; references to common lisp functions from the calling tree. +;;; +;;; DEFINE-VARIABLE-PATTERN (name &optional caller-type) [MACRO] +;;; Defines NAME as a variable reference of type CALLER-TYPE. This is +;;; mainly used to establish the caller-type of the variable. +;;; +;;; DEFINE-CALLER-PATTERN-SYNONYMS (source destinations) [MACRO] +;;; For defining function caller pattern syntax synonyms. For each name +;;; in DESTINATIONS, defines its pattern as a copy of the definition +;;; of SOURCE. Allows a large number of identical patterns to be defined +;;; simultaneously. Must occur after the SOURCE has been defined. +;;; +;;; ----- +;;; This system includes pattern definitions for the latest +;;; common lisp specification, as published in Guy Steele, +;;; Common Lisp: The Language, 2nd Edition. +;;; +;;; Patterns may be either structures to match, or a predicate +;;; like symbolp/numberp/stringp. The pattern specification language +;;; is similar to the notation used in CLtL2, but in a more lisp-like +;;; form: +;;; (:eq name) The form element must be eq to the symbol NAME. +;;; (:test test) TEST must be true when applied to the form element. +;;; (:typep type) The form element must be of type TYPE. +;;; (:or pat1 pat2 ...) Tries each of the patterns in left-to-right order, +;;; until one succeeds. +;;; Equivalent to { pat1 | pat2 | ... } +;;; (:rest pattern) The remaining form elements are grouped into a +;;; list which is matched against PATTERN. +;;; (:optional pat1 ...) The patterns may optionally match against the +;;; form element. +;;; Equivalent to [ pat1 ... ]. +;;; (:star pat1 ...) The patterns may match against the patterns +;;; any number of times, including 0. +;;; Equivalent to { pat1 ... }*. +;;; (:plus pat1 ...) The patterns may match against the patterns +;;; any number of times, but at least once. +;;; Equivalent to { pat1 ... }+. +;;; &optional, &key, Similar in behavior to the corresponding +;;; &rest lambda-list keywords. +;;; FORM A random lisp form. If a cons, assumes the +;;; car is a function or macro and tries to +;;; match the args against that symbol's pattern. +;;; If a symbol, assumes it's a variable reference. +;;; :ignore Ignores the corresponding form element. +;;; NAME The corresponding form element should be +;;; the name of a new definition (e.g., the +;;; first arg in a defun pattern is NAME. +;;; FUNCTION, MACRO The corresponding form element should be +;;; a function reference not handled by FORM. +;;; Used in the definition of apply and funcall. +;;; VAR The corresponding form element should be +;;; a variable definition or mutation. Used +;;; in the definition of let, let*, etc. +;;; VARIABLE The corresponding form element should be +;;; a variable reference. +;;; +;;; In all other pattern symbols, it looks up the symbols pattern substitution +;;; and recursively matches against the pattern. Automatically destructures +;;; list structure that does not include consing dots. +;;; +;;; Among the pattern substitution names defined are: +;;; STRING, SYMBOL, NUMBER Appropriate :test patterns. +;;; LAMBDA-LIST Matches against a lambda list. +;;; BODY Matches against a function body definition. +;;; FN Matches against #'function, 'function, +;;; and lambdas. This is used in the definition +;;; of apply, funcall, and the mapping patterns. +;;; and others... +;;; +;;; Here's some sample pattern definitions: +;;; (define-caller-pattern defun +;;; (name lambda-list +;;; (:star (:or documentation-string declaration)) +;;; (:star form)) +;;; :lisp) +;;; (define-caller-pattern funcall (fn (:star form)) :lisp) +;;; +;;; In general, the system is intelligent enough to handle any sort of +;;; simple funcall. One only need specify the syntax for functions and +;;; macros which use optional arguments, keyword arguments, or some +;;; argument positions are special, such as in apply and funcall, or +;;; to indicate that the function is of the specified caller type. +;;; +;;; +;;; NOTES: +;;; +;;; XRef assumes syntactically correct lisp code. +;;; +;;; This is by no means perfect. For example, let and let* are treated +;;; identically, instead of differentiating between serial and parallel +;;; binding. But it's still a useful tool. It can be helpful in +;;; maintaining code, debugging problems with patch files, determining +;;; whether functions are multiply defined, and help you remember where +;;; a function is defined or called. +;;; +;;; XREF runs best when compiled. + +;;; ******************************** +;;; References ********************* +;;; ******************************** +;;; +;;; Xerox Interlisp Masterscope Program: +;;; Larry M Masinter, Global program analysis in an interactive environment +;;; PhD Thesis, Stanford University, 1980. +;;; +;;; Symbolics Who-Calls Database: +;;; User's Guide to Symbolics Computers, Volume 1, Cambridge, MA, July 1986 +;;; Genera 7.0, pp 183-185. +;;; + +;;; ******************************** +;;; Example ************************ +;;; ******************************** +;;; +;;; Here is an example of running XREF on a short program. +;;; [In Scribe documentation, give a simple short program and resulting +;;; XREF output, including postscript call graphs.] +#| +<cl> (xref:xref-file "/afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp") +Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp. +................................................ +48 forms processed. +<cl> (xref:display-database :readers) + +*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE. +*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO. +*DIRECTION* is referenced by CREATE-POSITION-INFO. +*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT. +*ROOT-IS-SEQUENCE* is referenced by GRAPH. +*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE. +*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO. +*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE. +*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE. +*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE. +<cl> (xref:print-caller-trees :root-nodes '(display-graph)) + +Rooted calling trees: + DISPLAY-GRAPH + CREATE-POSITION-INFO + CALCULATE-POSITION-INFO + CALCULATE-POSITION + NODE-POSITION-ALREADY-SET-FLAG + NODE-LEVEL-ALREADY-SET-FLAG + CALCULATE-POSITION-IN-LEVEL + NODE-CHILDREN + NODE-LEVEL + CALCULATE-POSITION + NEW-CALCULATE-BREADTH + NODE-CHILDREN + BREADTH + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + NEW-CALCULATE-BREADTH + NODE-PARENTS + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + OPPOSITE-POSITION + NODE-Y + NODE-X + NODE-LEVEL + CALCULATE-LEVEL-POSITION + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + DIMENSION + NODE-WIDTH + NODE-HEIGHT + CALCULATE-LEVEL-POSITION-BEFORE + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + NODE-WIDTH + NODE-HEIGHT + DIMENSION + NODE-WIDTH + NODE-HEIGHT +|# + +;;; **************************************************************** +;;; List Callers *************************************************** +;;; **************************************************************** + +(defpackage :pxref + (:use :common-lisp) + (:export #:list-callers + #:list-users + #:list-readers + #:list-setters + #:what-files-call + #:who-calls + #:list-callees + #:source-file + #:clear-tables + #:define-pattern-substitution + #:define-caller-pattern + #:define-variable-pattern + #:define-caller-pattern-synonyms + #:clear-patterns + #:*last-form* + #:*xref-verbose* + #:*handle-package-forms* + #:*handle-function-forms* + #:*handle-macro-forms* + #:*types-to-ignore* + #:*last-caller-tree* + #:*default-graphing-mode* + #:*indent-amount* + #:xref-file + #:xref-files + #:write-callers-database-to-file + #:display-database + #:print-caller-trees + #:make-caller-tree + #:print-indented-tree + #:determine-file-dependencies + #:print-file-dependencies + #:psgraph-xref + )) + +(in-package "PXREF") + +;;; Warn user if they're loading the source instead of compiling it first. +;(eval-when (compile load eval) +; (defvar compiled-p nil)) +;(eval-when (compile load) +; (setq compiled-p t)) +;(eval-when (load eval) +; (unless compiled-p +; (warn "This file should be compiled before loading for best results."))) +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + + +;;; ******************************** +;;; Primitives ********************* +;;; ******************************** +(defun lookup (symbol environment) + (dolist (frame environment) + (when (member symbol frame) + (return symbol)))) + +(defun car-eq (list item) + (and (consp list) + (eq (car list) item))) + +;;; ******************************** +;;; Callers Database *************** +;;; ******************************** +(defvar *file-callers-database* (make-hash-table :test #'equal) + "Contains name and list of file callers (files which call) for that name.") +(defvar *callers-database* (make-hash-table :test #'equal) + "Contains name and list of callers (function invocation) for that name.") +(defvar *readers-database* (make-hash-table :test #'equal) + "Contains name and list of readers (variable use) for that name.") +(defvar *setters-database* (make-hash-table :test #'equal) + "Contains name and list of setters (variable mutation) for that name.") +(defvar *callees-database* (make-hash-table :test #'equal) + "Contains name and list of functions and variables it calls.") +(defun callers-list (name &optional (database :callers)) + (case database + (:file (gethash name *file-callers-database*)) + (:callees (gethash name *callees-database*)) + (:callers (gethash name *callers-database*)) + (:readers (gethash name *readers-database*)) + (:setters (gethash name *setters-database*)))) +(defsetf callers-list (name &optional (database :callers)) (caller) + `(setf (gethash ,name (case ,database + (:file *file-callers-database*) + (:callees *callees-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*))) + ,caller)) + +(defun list-callers (symbol) + "Lists all functions which call SYMBOL as a function (function invocation)." + (callers-list symbol :callers)) +(defun list-readers (symbol) + "Lists all functions which refer to SYMBOL as a variable + (variable reference)." + (callers-list symbol :readers)) +(defun list-setters (symbol) + "Lists all functions which bind/set SYMBOL as a variable + (variable mutation)." + (callers-list symbol :setters)) +(defun list-users (symbol) + "Lists all functions which use SYMBOL as a variable or function." + (values (list-callers symbol) + (list-readers symbol) + (list-setters symbol))) +(defun who-calls (symbol &optional how) + "Lists callers of symbol. HOW may be :function, :reader, :setter, + or :variable." + ;; would be nice to have :macro and distinguish variable + ;; binding from assignment. (i.e., variable binding, assignment, and use) + (case how + (:function (list-callers symbol)) + (:reader (list-readers symbol)) + (:setter (list-setters symbol)) + (:variable (append (list-readers symbol) + (list-setters symbol))) + (otherwise (append (list-callers symbol) + (list-readers symbol) + (list-setters symbol))))) +(defun what-files-call (symbol) + "Lists names of files that contain uses of SYMBOL + as a function, variable, or constant." + (callers-list symbol :file)) +(defun list-callees (symbol) + "Lists names of functions and variables called by SYMBOL." + (callers-list symbol :callees)) + +(defvar *source-file* (make-hash-table :test #'equal) + "Contains function name and source file for that name.") +(defun source-file (symbol) + "Lists the names of files in which SYMBOL is defined/used." + (gethash symbol *source-file*)) +(defsetf source-file (name) (value) + `(setf (gethash ,name *source-file*) ,value)) + +(defun clear-tables () + (clrhash *file-callers-database*) + (clrhash *callers-database*) + (clrhash *callees-database*) + (clrhash *readers-database*) + (clrhash *setters-database*) + (clrhash *source-file*)) + + +;;; ******************************** +;;; Pattern Database *************** +;;; ******************************** +;;; Pattern Types +(defvar *pattern-caller-type* (make-hash-table :test #'equal)) +(defun pattern-caller-type (name) + (gethash name *pattern-caller-type*)) +(defsetf pattern-caller-type (name) (value) + `(setf (gethash ,name *pattern-caller-type*) ,value)) + +;;; Pattern Substitutions +(defvar *pattern-substitution-table* (make-hash-table :test #'equal) + "Stores general patterns for function destructuring.") +(defun lookup-pattern-substitution (name) + (gethash name *pattern-substitution-table*)) +(defmacro define-pattern-substitution (name pattern) + "Defines NAME to be equivalent to the specified pattern. Useful for + making patterns more readable. For example, the LAMBDA-LIST is + defined as a pattern substitution, making the definition of the + DEFUN caller-pattern simpler." + `(setf (gethash ',name *pattern-substitution-table*) + ',pattern)) + +;;; Function/Macro caller patterns: +;;; The car of the form is skipped, so we don't need to specify +;;; (:eq function-name) like we would for a substitution. +;;; +;;; Patterns must be defined in the XREF package because the pattern +;;; language is tested by comparing symbols (using #'equal) and not +;;; their printreps. This is fine for the lisp grammer, because the XREF +;;; package depends on the LISP package, so a symbol like 'xref::cons is +;;; translated automatically into 'lisp::cons. However, since +;;; (equal 'foo::bar 'baz::bar) returns nil unless both 'foo::bar and +;;; 'baz::bar are inherited from the same package (e.g., LISP), +;;; if package handling is turned on the user must specify package +;;; names in the caller pattern definitions for functions that occur +;;; in packages other than LISP, otherwise the symbols will not match. +;;; +;;; Perhaps we should enforce the definition of caller patterns in the +;;; XREF package by wrapping the body of define-caller-pattern in +;;; the XREF package: +;;; (defmacro define-caller-pattern (name value &optional caller-type) +;;; (let ((old-package *package*)) +;;; (setf *package* (find-package "XREF")) +;;; (prog1 +;;; `(progn +;;; (when ',caller-type +;;; (setf (pattern-caller-type ',name) ',caller-type)) +;;; (when ',value +;;; (setf (gethash ',name *caller-pattern-table*) +;;; ',value))) +;;; (setf *package* old-package)))) +;;; Either that, or for the purpose of pattern testing we should compare +;;; printreps. [The latter makes the primitive patterns like VAR +;;; reserved words.] +(defvar *caller-pattern-table* (make-hash-table :test #'equal) + "Stores patterns for function destructuring.") +(defun lookup-caller-pattern (name) + (gethash name *caller-pattern-table*)) +(defmacro define-caller-pattern (name pattern &optional caller-type) + "Defines NAME as a function/macro call with argument structure + described by PATTERN. CALLER-TYPE, if specified, assigns a type to + the pattern, which may be used to exclude references to NAME while + viewing the database. For example, all the Common Lisp definitions + have a caller-type of :lisp or :lisp2, so that you can exclude + references to common lisp functions from the calling tree." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)) + (when ',pattern + (setf (gethash ',name *caller-pattern-table*) + ',pattern)))) + +;;; For defining variables +(defmacro define-variable-pattern (name &optional caller-type) + "Defines NAME as a variable reference of type CALLER-TYPE. This is + mainly used to establish the caller-type of the variable." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)))) + +;;; For defining synonyms. Means much less space taken up by the patterns. +(defmacro define-caller-pattern-synonyms (source destinations) + "For defining function caller pattern syntax synonyms. For each name + in DESTINATIONS, defines its pattern as a copy of the definition of SOURCE. + Allows a large number of identical patterns to be defined simultaneously. + Must occur after the SOURCE has been defined." + `(let ((source-type (pattern-caller-type ',source)) + (source-pattern (gethash ',source *caller-pattern-table*))) + (when source-type + (dolist (dest ',destinations) + (setf (pattern-caller-type dest) source-type))) + (when source-pattern + (dolist (dest ',destinations) + (setf (gethash dest *caller-pattern-table*) + source-pattern))))) + +(defun clear-patterns () + (clrhash *pattern-substitution-table*) + (clrhash *caller-pattern-table*) + (clrhash *pattern-caller-type*)) + +;;; ******************************** +;;; Cross Reference Files ********** +;;; ******************************** +(defvar *last-form* () + "The last form read from the file. Useful for figuring out what went wrong + when xref-file drops into the debugger.") + +(defvar *xref-verbose* t + "When T, xref-file(s) prints out the names of the files it looks at, + progress dots, and the number of forms read.") + +;;; This needs to first clear the tables? +(defun xref-files (&rest files) + "Grovels over the lisp code located in source file FILES, using xref-file." + ;; If the arg is a list, use it. + (when (listp (car files)) (setq files (car files))) + (dolist (file files) + (xref-file file nil)) + (values)) + +(defvar *handle-package-forms* nil ;'(lisp::in-package) + "When non-NIL, and XREF-FILE sees a package-setting form like IN-PACKAGE, + sets the current package to the specified package by evaluating the + form. When done with the file, xref-file resets the package to its + original value. In some of the displaying functions, when this variable + is non-NIL one may specify that all symbols from a particular set of + packages be ignored. This is only useful if the files use different + packages with conflicting names.") + +(defvar *normal-readtable* (copy-readtable nil) + "Normal, unadulterated CL readtable.") + +(defun xref-file (filename &optional (clear-tables t) (verbose *xref-verbose*)) + "Cross references the function and variable calls in FILENAME by + walking over the source code located in the file. Defaults type of + filename to ".lisp". Chomps on the code using record-callers and + record-callers*. If CLEAR-TABLES is T (the default), it clears the callers + database before processing the file. Specify CLEAR-TABLES as nil to + append to the database. If VERBOSE is T (the default), prints out the + name of the file, one progress dot for each form processed, and the + total number of forms." + ;; Default type to "lisp" + (when (and (null (pathname-type filename)) + (not (probe-file filename))) + (cond ((stringp filename) + (setf filename (concatenate 'string filename ".lisp"))) + ((pathnamep filename) + (setf filename (merge-pathnames filename + (make-pathname :type "lisp")))))) + (when clear-tables (clear-tables)) + (let ((count 0) + (old-package *package*) + (*readtable* *normal-readtable*)) + (when verbose + (format t "~&Cross-referencing file ~A.~&" filename)) + (with-open-file (stream filename :direction :input) + (do ((form (read stream nil :eof) (read stream nil :eof))) + ((eq form :eof)) + (incf count) + (when verbose + (format *standard-output* ".") + (force-output *standard-output*)) + (setq *last-form* form) + (record-callers filename form) + ;; Package Magic. + (when (and *handle-package-forms* + (consp form) + (member (car form) *handle-package-forms*)) + (eval form)))) + (when verbose + (format t "~&~D forms processed." count)) + (setq *package* old-package) + (values))) + +(defvar *handle-function-forms* t + "When T, XREF-FILE tries to be smart about forms which occur in + a function position, such as lambdas and arbitrary Lisp forms. + If so, it recursively calls record-callers with pattern 'FORM. + If the form is a lambda, makes the caller a caller of :unnamed-lambda.") + +(defvar *handle-macro-forms* t + "When T, if the file was loaded before being processed by XREF, and the + car of a form is a macro, it notes that the parent calls the macro, + and then calls macroexpand-1 on the form.") + +(defvar *callees-database-includes-variables* nil) + +(defun record-callers (filename form + &optional pattern parent (environment nil) + funcall) + "RECORD-CALLERS is the main routine used to walk down the code. It matches + the PATTERN against the FORM, possibly adding statements to the database. + PARENT is the name defined by the current outermost definition; it is + the caller of the forms in the body (e.g., FORM). ENVIRONMENT is used + to keep track of the scoping of variables. FUNCALL deals with the type + of variable assignment and hence how the environment should be modified. + RECORD-CALLERS handles atomic patterns and simple list-structure patterns. + For complex list-structure pattern destructuring, it calls RECORD-CALLERS*." +; (when form) + (unless pattern (setq pattern 'FORM)) + (cond ((symbolp pattern) + (case pattern + (:IGNORE + ;; Ignores the rest of the form. + (values t parent environment)) + (NAME + ;; This is the name of a new definition. + (push filename (source-file form)) + (values t form environment)) + ((FUNCTION MACRO) + ;; This is the name of a call. + (cond ((and *handle-function-forms* (consp form)) + ;; If we're a cons and special handling is on, + (when (eq (car form) 'lambda) + (pushnew filename (callers-list :unnamed-lambda :file)) + (when parent + (pushnew parent (callers-list :unnamed-lambda + :callers)) + (pushnew :unnamed-lambda (callers-list parent + :callees)))) + (record-callers filename form 'form parent environment)) + (t + ;; If we're just a regular function name call. + (pushnew filename (callers-list form :file)) + (when parent + (pushnew parent (callers-list form :callers)) + (pushnew form (callers-list parent :callees))) + (values t parent environment)))) + (VAR + ;; This is the name of a new variable definition. + ;; Includes arglist parameters. + (when (and (symbolp form) (not (keywordp form)) + (not (member form lambda-list-keywords))) + (pushnew form (car environment)) + (pushnew filename (callers-list form :file)) + (when parent +; (pushnew form (callers-list parent :callees)) + (pushnew parent (callers-list form :setters))) + (values t parent environment))) + (VARIABLE + ;; VAR reference + (pushnew filename (callers-list form :file)) + (when (and parent (not (lookup form environment))) + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees)))) + (values t parent environment)) + (FORM + ;; A random form (var or funcall). + (cond ((consp form) + ;; Get new pattern from TAG. + (let ((new-pattern (lookup-caller-pattern (car form)))) + (pushnew filename (callers-list (car form) :file)) + (when parent + (pushnew parent (callers-list (car form) :callers)) + (pushnew (car form) (callers-list parent :callees))) + (cond ((and new-pattern (cdr form)) + ;; Special Pattern and there's stuff left + ;; to be processed. Note that we check if + ;; a pattern is defined for the form before + ;; we check to see if we can macroexpand it. + (record-callers filename (cdr form) new-pattern + parent environment :funcall)) + ((and *handle-macro-forms* + (symbolp (car form)) ; pnorvig 9/9/93 + (macro-function (car form))) + ;; The car of the form is a macro and + ;; macro processing is turned on. Macroexpand-1 + ;; the form and try again. + (record-callers filename + (macroexpand-1 form) + 'form parent environment + :funcall)) + ((null (cdr form)) + ;; No more left to be processed. Note that + ;; this must occur after the macros clause, + ;; since macros can expand into more code. + (values t parent environment)) + (t + ;; Random Form. We assume it is a function call. + (record-callers filename (cdr form) + '((:star FORM)) + parent environment :funcall))))) + (t + (when (and (not (lookup form environment)) + (not (numberp form)) + ;; the following line should probably be + ;; commented out? + (not (keywordp form)) + (not (stringp form)) + (not (eq form t)) + (not (eq form nil))) + (pushnew filename (callers-list form :file)) + ;; ??? :callers + (when parent + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees))))) + (values t parent environment)))) + (otherwise + ;; Pattern Substitution + (let ((new-pattern (lookup-pattern-substitution pattern))) + (if new-pattern + (record-callers filename form new-pattern + parent environment) + (when (eq pattern form) + (values t parent environment))))))) + ((consp pattern) + (case (car pattern) + (:eq (when (eq (second pattern) form) + (values t parent environment))) + (:test (when (funcall (eval (second pattern)) form) + (values t parent environment))) + (:typep (when (typep form (second pattern)) + (values t parent environment))) + (:or (dolist (subpat (rest pattern)) + (multiple-value-bind (processed parent environment) + (record-callers filename form subpat + parent environment) + (when processed + (return (values processed parent environment)))))) + (:rest ; (:star :plus :optional :rest) + (record-callers filename form (second pattern) + parent environment)) + (otherwise + (multiple-value-bind (d p env) + (record-callers* filename form pattern + parent (cons nil environment)) + (values d p (if funcall environment env)))))))) + +(defun record-callers* (filename form pattern parent environment + &optional continuation + in-optionals in-keywords) + "RECORD-CALLERS* handles complex list-structure patterns, such as + ordered lists of subpatterns, patterns involving :star, :plus, + &optional, &key, &rest, and so on. CONTINUATION is a stack of + unprocessed patterns, IN-OPTIONALS and IN-KEYWORDS are corresponding + stacks which determine whether &rest or &key has been seen yet in + the current pattern." + ;; form must be a cons or nil. +; (when form) + (if (null pattern) + (if (null continuation) + (values t parent environment) + (record-callers* filename form (car continuation) parent environment + (cdr continuation) + (cdr in-optionals) + (cdr in-keywords))) + (let ((pattern-elt (car pattern))) + (cond ((car-eq pattern-elt :optional) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cdr pattern) continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :star) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons pattern continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :plus) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cons (cons :star (cdr pattern-elt)) + (cdr pattern)) + continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords))) + ((car-eq pattern-elt :rest) + (record-callers filename form pattern-elt parent environment)) + ((eq pattern-elt '&optional) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons t in-optionals) + (cons (car in-keywords) in-keywords))) + ((eq pattern-elt '&rest) + (record-callers filename form (second pattern) + parent environment)) + ((eq pattern-elt '&key) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons (car in-optionals) in-optionals) + (cons t in-keywords))) + ((null form) + (when (or (car in-keywords) (car in-optionals)) + (values t parent environment))) + ((consp form) + (multiple-value-bind (processed parent environment) + (record-callers filename (if (car in-keywords) + (cadr form) + (car form)) + pattern-elt + parent environment) + (cond (processed + (record-callers* filename (if (car in-keywords) + (cddr form) + (cdr form)) + (cdr pattern) + parent environment + continuation + in-optionals in-keywords)) + ((or (car in-keywords) + (car in-optionals)) + (values t parent environment))))))))) + + +;;; ******************************** +;;; Misc Utilities ***************** +;;; ******************************** +(defvar *types-to-ignore* + '(:lisp ; CLtL 1st Edition + :lisp2 ; CLtL 2nd Edition additional patterns + ) + "Default set of caller types (as specified in the patterns) to ignore + in the database handling functions. :lisp is CLtL 1st edition, + :lisp2 is additional patterns from CLtL 2nd edition.") + +(defun display-database (&optional (database :callers) + (types-to-ignore *types-to-ignore*)) + "Prints out the name of each symbol and all its callers. Specify database + :callers (the default) to get function call references, :fill to the get + files in which the symbol is called, :readers to get variable references, + and :setters to get variable binding and assignments. Ignores functions + of types listed in types-to-ignore." + (maphash #'(lambda (name callers) + (unless (or (member (pattern-caller-type name) + types-to-ignore) + ;; When we're doing fancy package crap, + ;; allow us to ignore symbols based on their + ;; packages. + (when *handle-package-forms* + (member (symbol-package name) + types-to-ignore + :key #'find-package))) + (format t "~&~S is referenced by~{ ~S~}." + name callers))) + (ecase database + (:file *file-callers-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*)))) + +(defun write-callers-database-to-file (filename) + "Saves the contents of the current callers database to a file. This + file can be loaded to restore the previous contents of the + database. (For large systems it can take a long time to crunch + through the code, so this can save some time.)" + (with-open-file (stream filename :direction :output) + (format stream "~&(clear-tables)") + (maphash #'(lambda (x y) + (format stream "~&(setf (source-file '~S) '~S)" + x y)) + *source-file*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :file) '~S)" + x y)) + *file-callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callers) '~S)" + x y)) + *callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callees) '~S)" + x y)) + *callees-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :readers) '~S)" + x y)) + *readers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :setters) '~S)" + x y)) + *setters-database*))) + + +;;; ******************************** +;;; Print Caller Trees ************* +;;; ******************************** +;;; The following function is useful for reversing a caller table into +;;; a callee table. Possibly later we'll extend xref to create two +;;; such database hash tables. Needs to include vars as well. +(defun invert-hash-table (table &optional (types-to-ignore *types-to-ignore*)) + "Makes a copy of the hash table in which (name value*) pairs + are inverted to (value name*) pairs." + (let ((target (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (dolist (value values) + (unless (member (pattern-caller-type key) + types-to-ignore) + (pushnew key (gethash value target))))) + table) + target)) + +;;; Resolve file references for automatic creation of a defsystem file. +(defun determine-file-dependencies (&optional (database *callers-database*)) + "Makes a hash table of file dependencies for the references listed in + DATABASE. This function may be useful for automatically resolving + file references for automatic creation of a system definition (defsystem)." + (let ((file-ref-ht (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (let ((key-file (source-file key))) + (when key + (dolist (value values) + (let ((value-file (source-file value))) + (when value-file + (dolist (s key-file) + (dolist (d value-file) + (pushnew d (gethash s file-ref-ht)))))))))) + database) + file-ref-ht)) + +(defun print-file-dependencies (&optional (database *callers-database*)) + "Prints a list of file dependencies for the references listed in DATABASE. + This function may be useful for automatically computing file loading + constraints for a system definition tool." + (maphash #'(lambda (key value) (format t "~&~S --> ~S" key value)) + (determine-file-dependencies database))) + +;;; The following functions demonstrate a possible way to interface +;;; xref to a graphical browser such as psgraph to mimic the capabilities +;;; of Masterscope's graphical browser. + +(defvar *last-caller-tree* nil) + +(defvar *default-graphing-mode* :call-graph + "Specifies whether we graph up or down. If :call-graph, the children + of a node are the functions it calls. If :caller-graph, the children + of a node are the functions that call it.") + +(defun gather-tree (parents &optional already-seen + (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Extends the tree, copying it into list structure, until it repeats + a reference (hits a cycle)." + (let ((*already-seen* nil) + (database (case mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (declare (special *already-seen*)) + (labels + ((amass-tree + (parents &optional already-seen) + (let (result this-item) + (dolist (parent parents) + (unless (member (pattern-caller-type parent) + types-to-ignore) + (pushnew parent *already-seen*) + (if (member parent already-seen) + (setq this-item nil) ; :ignore + (if compact + (multiple-value-setq (this-item already-seen) + (amass-tree (gethash parent database) + (cons parent already-seen))) + (setq this-item + (amass-tree (gethash parent database) + (cons parent already-seen))))) + (setq parent (format nil "~S" parent)) + (when (consp parent) (setq parent (cons :xref-list parent))) + (unless (eq this-item :ignore) + (push (if this-item + (list parent this-item) + parent) + result)))) + (values result ;(reverse result) + already-seen)))) + (values (amass-tree parents already-seen) + *already-seen*)))) + +(defun find-roots-and-cycles (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*)) + "Returns a list of uncalled callers (roots) and called callers (potential + cycles)." + (let ((uncalled-callers nil) + (called-callers nil) + (database (ecase mode + (:call-graph *callers-database*) + (:caller-graph *callees-database*))) + (other-database (ecase mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (maphash #'(lambda (name value) + (declare (ignore value)) + (unless (member (pattern-caller-type name) + types-to-ignore) + (if (gethash name database) + (push name called-callers) + (push name uncalled-callers)))) + other-database) + (values uncalled-callers called-callers))) + +(defun make-caller-tree (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Outputs list structure of a tree which roughly represents the possibly + cyclical structure of the caller database. + If mode is :call-graph, the children of a node are the functions it calls. + If mode is :caller-graph, the children of a node are the functions that + call it. + If compact is T, tries to eliminate the already-seen nodes, so that + the graph for a node is printed at most once. Otherwise it will duplicate + the node's tree (except for cycles). This is usefull because the call tree + is actually a directed graph, so we can either duplicate references or + display only the first one." + ;; Would be nice to print out line numbers and whenever we skip a duplicated + ;; reference, print the line number of the full reference after the node. + (multiple-value-bind (uncalled-callers called-callers) + (find-roots-and-cycles mode types-to-ignore) + (multiple-value-bind (trees already-seen) + (gather-tree uncalled-callers nil mode types-to-ignore compact) + (setq *last-caller-tree* trees) + (let ((more-trees (gather-tree (set-difference called-callers + already-seen) + already-seen + mode types-to-ignore compact))) + (values trees more-trees))))) + +(defvar *indent-amount* 3 + "Number of spaces to indent successive levels in PRINT-INDENTED-TREE.") + +(defun print-indented-tree (trees &optional (indent 0)) + "Simple code to print out a list-structure tree (such as those created + by make-caller-tree) as indented text." + (when trees + (dolist (tree trees) + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (format t "~&~VT~A" indent (cdr tree))) + ((listp tree) + (format t "~&~VT~A" indent (car tree)) + (print-indented-tree (cadr tree) (+ indent *indent-amount*))) + (t + (format t "~&~VT~A" indent tree)))))) + +(defun print-caller-trees (&key (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) + compact + root-nodes) + "Prints the calling trees (which may actually be a full graph and not + necessarily a DAG) as indented text trees using PRINT-INDENTED-TREE. + MODE is :call-graph for trees where the children of a node are the + functions called by the node, or :caller-graph for trees where the + children of a node are the functions the node calls. TYPES-TO-IGNORE + is a list of funcall types (as specified in the patterns) to ignore + in printing out the database. For example, '(:lisp) would ignore all + calls to common lisp functions. COMPACT is a flag to tell the program + to try to compact the trees a bit by not printing trees if they have + already been seen. ROOT-NODES is a list of root nodes of trees to + display. If ROOT-NODES is nil, tries to find all root nodes in the + database." + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (when rooted + (format t "~&Rooted calling trees:") + (print-indented-tree rooted 2)) + (when cycles + (when rooted + (format t "~2%")) + (format t "~&Cyclic calling trees:") + (print-indented-tree cycles 2)))) + + +;;; ******************************** +;;; Interface to PSGraph *********** +;;; ******************************** +#| +;;; Interface to Bates' PostScript Graphing Utility +(load "/afs/cs/user/mkant/Lisp/PSGraph/psgraph") + +(defparameter *postscript-output-directory* "") +(defun psgraph-xref (&key (mode *default-graphing-mode*) + (output-directory *postscript-output-directory*) + (types-to-ignore *types-to-ignore*) + (compact t) + (shrink t) + root-nodes + insert) + ;; If root-nodes is a non-nil list, uses that list as the starting + ;; position. Otherwise tries to find all roots in the database. + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (psgraph-output (append rooted cycles) output-directory shrink insert))) + +(defun psgraph-output (list-of-trees directory shrink &optional insert) + (let ((psgraph:*fontsize* 9) + (psgraph:*second-fontsize* 7) +; (psgraph:*boxkind* "fill") + (psgraph:*boxgray* "0") ; .8 + (psgraph:*edgewidth* "1") + (psgraph:*edgegray* "0")) + (labels ((stringify (thing) + (cond ((stringp thing) (string-downcase thing)) + ((symbolp thing) (string-downcase (symbol-name thing))) + ((and (listp thing) (eq (car thing) :xref-list)) + (stringify (cdr thing))) + ((listp thing) (stringify (car thing))) + (t (string thing))))) + (dolist (item list-of-trees) + (let* ((fname (stringify item)) + (filename (concatenate 'string directory + (string-trim '(#: #|) fname) + ".ps"))) + (format t "~&Creating PostScript file ~S." filename) + (with-open-file (*standard-output* filename + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + ;; Note that the #'eq prints the DAG as a tree. If + ;; you replace it with #'equal, it will print it as + ;; a DAG, which I think is slightly ugly. + (psgraph:psgraph item + #'caller-tree-children #'caller-info shrink + insert #'eq))))))) + +(defun caller-tree-children (tree) + (when (and tree (listp tree) (not (eq (car tree) :xref-list))) + (cadr tree))) + +(defun caller-tree-node (tree) + (when tree + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (cdr tree)) + ((listp tree) + (car tree)) + (t + tree)))) + +(defun caller-info (tree) + (let ((node (caller-tree-node tree))) + (list node))) +|# +#| +;;; Code to print out graphical trees of CLOS class hierarchies. +(defun print-class-hierarchy (&optional (start-class 'anything) + (file "classes.ps")) + (let ((start (find-class start-class))) + (when start + (with-open-file (*standard-output* file :direction :output) + (psgraph:psgraph start + #'clos::class-direct-subclasses + #'(lambda (x) + (list (format nil "~A" (clos::class-name x)))) + t nil #'eq))))) + +|# + + +;;; **************************************************************** +;;; Cross Referencing Patterns for Common Lisp ********************* +;;; **************************************************************** +(clear-patterns) + +;;; ******************************** +;;; Pattern Substitutions ********** +;;; ******************************** +(define-pattern-substitution integer (:test #'integerp)) +(define-pattern-substitution rational (:test #'rationalp)) +(define-pattern-substitution symbol (:test #'symbolp)) +(define-pattern-substitution string (:test #'stringp)) +(define-pattern-substitution number (:test #'numberp)) +(define-pattern-substitution lambda-list + ((:star var) + (:optional (:eq &optional) + (:star (:or var + (var (:optional form (:optional var)))))) + (:optional (:eq &rest) var) + (:optional (:eq &key) (:star (:or var + ((:or var + (keyword var)) + (:optional form (:optional var))))) + (:optional &allow-other-keys)) + (:optional (:eq &aux) + (:star (:or var + (var (:optional form))))))) +(define-pattern-substitution test form) +(define-pattern-substitution body + ((:star (:or declaration documentation-string)) + (:star form))) +(define-pattern-substitution documentation-string string) +(define-pattern-substitution initial-value form) +(define-pattern-substitution tag symbol) +(define-pattern-substitution declaration ((:eq declare)(:rest :ignore))) +(define-pattern-substitution destination form) +(define-pattern-substitution control-string string) +(define-pattern-substitution format-arguments + ((:star form))) +(define-pattern-substitution fn + (:or ((:eq quote) function) + ((:eq function) function) + function)) + +;;; ******************************** +;;; Caller Patterns **************** +;;; ******************************** + +;;; Types Related +(define-caller-pattern coerce (form :ignore) :lisp) +(define-caller-pattern type-of (form) :lisp) +(define-caller-pattern upgraded-array-element-type (:ignore) :lisp2) +(define-caller-pattern upgraded-complex-part-type (:ignore) :lisp2) + +;;; Lambdas and Definitions +(define-variable-pattern lambda-list-keywords :lisp) +(define-variable-pattern lambda-parameters-limit :lisp) +(define-caller-pattern lambda (lambda-list (:rest body)) :lisp) + +(define-caller-pattern defun + (name lambda-list + (:star (:or documentation-string declaration)) + (:star form)) + :lisp) + +;;; perhaps this should use VAR, instead of NAME +(define-caller-pattern defvar + (var (:optional initial-value (:optional documentation-string))) + :lisp) +(define-caller-pattern defparameter + (var initial-value (:optional documentation-string)) + :lisp) +(define-caller-pattern defconstant + (var initial-value (:optional documentation-string)) + :lisp) + +(define-caller-pattern eval-when + (:ignore ; the situations + (:star form)) + :lisp) + +;;; Logical Values +(define-variable-pattern nil :lisp) +(define-variable-pattern t :lisp) + +;;; Predicates +(define-caller-pattern typep (form form) :lisp) +(define-caller-pattern subtypep (form form) :lisp) + +(define-caller-pattern null (form) :lisp) +(define-caller-pattern symbolp (form) :lisp) +(define-caller-pattern atom (form) :lisp) +(define-caller-pattern consp (form) :lisp) +(define-caller-pattern listp (form) :lisp) +(define-caller-pattern numberp (form) :lisp) +(define-caller-pattern integerp (form) :lisp) +(define-caller-pattern rationalp (form) :lisp) +(define-caller-pattern floatp (form) :lisp) +(define-caller-pattern realp (form) :lisp2) +(define-caller-pattern complexp (form) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern stringp (form) :lisp) +(define-caller-pattern bit-vector-p (form) :lisp) +(define-caller-pattern vectorp (form) :lisp) +(define-caller-pattern simple-vector-p (form) :lisp) +(define-caller-pattern simple-string-p (form) :lisp) +(define-caller-pattern simple-bit-vector-p (form) :lisp) +(define-caller-pattern arrayp (form) :lisp) +(define-caller-pattern packagep (form) :lisp) +(define-caller-pattern functionp (form) :lisp) +(define-caller-pattern compiled-function-p (form) :lisp) +(define-caller-pattern commonp (form) :lisp) + +;;; Equality Predicates +(define-caller-pattern eq (form form) :lisp) +(define-caller-pattern eql (form form) :lisp) +(define-caller-pattern equal (form form) :lisp) +(define-caller-pattern equalp (form form) :lisp) + +;;; Logical Operators +(define-caller-pattern not (form) :lisp) +(define-caller-pattern or ((:star form)) :lisp) +(define-caller-pattern and ((:star form)) :lisp) + +;;; Reference + +;;; Quote is a problem. In Defmacro & friends, we'd like to actually +;;; look at the argument, 'cause it hides internal function calls +;;; of the defmacro. +(define-caller-pattern quote (:ignore) :lisp) + +(define-caller-pattern function ((:or fn form)) :lisp) +(define-caller-pattern symbol-value (form) :lisp) +(define-caller-pattern symbol-function (form) :lisp) +(define-caller-pattern fdefinition (form) :lisp2) +(define-caller-pattern boundp (form) :lisp) +(define-caller-pattern fboundp (form) :lisp) +(define-caller-pattern special-form-p (form) :lisp) + +;;; Assignment +(define-caller-pattern setq ((:star var form)) :lisp) +(define-caller-pattern psetq ((:star var form)) :lisp) +(define-caller-pattern set (form form) :lisp) +(define-caller-pattern makunbound (form) :lisp) +(define-caller-pattern fmakunbound (form) :lisp) + +;;; Generalized Variables +(define-caller-pattern setf ((:star form form)) :lisp) +(define-caller-pattern psetf ((:star form form)) :lisp) +(define-caller-pattern shiftf ((:plus form) form) :lisp) +(define-caller-pattern rotatef ((:star form)) :lisp) +(define-caller-pattern define-modify-macro + (name + lambda-list + fn + (:optional documentation-string)) + :lisp) +(define-caller-pattern defsetf + (:or (name name (:optional documentation-string)) + (name lambda-list (var) + (:star (:or declaration documentation-string)) + (:star form))) + :lisp) +(define-caller-pattern define-setf-method + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern get-setf-method (form) :lisp) +(define-caller-pattern get-setf-method-multiple-value (form) :lisp) + + +;;; Function invocation +(define-caller-pattern apply (fn form (:star form)) :lisp) +(define-caller-pattern funcall (fn (:star form)) :lisp) + + +;;; Simple sequencing +(define-caller-pattern progn ((:star form)) :lisp) +(define-caller-pattern prog1 (form (:star form)) :lisp) +(define-caller-pattern prog2 (form form (:star form)) :lisp) + +;;; Variable bindings +(define-caller-pattern let + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern let* + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern compiler-let + (((:star (:or var (var form)))) + (:star form)) + :lisp) +(define-caller-pattern progv + (form form (:star form)) :lisp) +(define-caller-pattern flet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern labels + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern macrolet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern symbol-macrolet + (((:star (var form))) (:star declaration) (:star form)) + :lisp2) + +;;; Conditionals +(define-caller-pattern if (test form (:optional form)) :lisp) +(define-caller-pattern when (test (:star form)) :lisp) +(define-caller-pattern unless (test (:star form)) :lisp) +(define-caller-pattern cond ((:star (test (:star form)))) :lisp) +(define-caller-pattern case + (form + (:star ((:or symbol + ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern typecase (form (:star (symbol (:star form)))) + :lisp) + +;;; Blocks and Exits +(define-caller-pattern block (name (:star form)) :lisp) +(define-caller-pattern return-from (function (:optional form)) :lisp) +(define-caller-pattern return ((:optional form)) :lisp) + +;;; Iteration +(define-caller-pattern loop ((:star form)) :lisp) +(define-caller-pattern do + (((:star (:or var + (var (:optional form (:optional form)))))) ; init step + (form (:star form)) ; end-test result + (:star declaration) + (:star (:or tag form))) ; statement + :lisp) +(define-caller-pattern do* + (((:star (:or var + (var (:optional form (:optional form)))))) + (form (:star form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dolist + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dotimes + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) + +;;; Mapping +(define-caller-pattern mapcar (fn form (:star form)) :lisp) +(define-caller-pattern maplist (fn form (:star form)) :lisp) +(define-caller-pattern mapc (fn form (:star form)) :lisp) +(define-caller-pattern mapl (fn form (:star form)) :lisp) +(define-caller-pattern mapcan (fn form (:star form)) :lisp) +(define-caller-pattern mapcon (fn form (:star form)) :lisp) + +;;; The "Program Feature" +(define-caller-pattern tagbody ((:star (:or tag form))) :lisp) +(define-caller-pattern prog + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern prog* + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern go (tag) :lisp) + +;;; Multiple Values +(define-caller-pattern values ((:star form)) :lisp) +(define-variable-pattern multiple-values-limit :lisp) +(define-caller-pattern values-list (form) :lisp) +(define-caller-pattern multiple-value-list (form) :lisp) +(define-caller-pattern multiple-value-call (fn (:star form)) :lisp) +(define-caller-pattern multiple-value-prog1 (form (:star form)) :lisp) +(define-caller-pattern multiple-value-bind + (((:star var)) form + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern multiple-value-setq (((:star var)) form) :lisp) +(define-caller-pattern nth-value (form form) :lisp2) + +;;; Dynamic Non-Local Exits +(define-caller-pattern catch (tag (:star form)) :lisp) +(define-caller-pattern throw (tag form) :lisp) +(define-caller-pattern unwind-protect (form (:star form)) :lisp) + +;;; Macros +(define-caller-pattern macro-function (form) :lisp) +(define-caller-pattern defmacro + (name + lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern macroexpand (form (:optional :ignore)) :lisp) +(define-caller-pattern macroexpand-1 (form (:optional :ignore)) :lisp) +(define-variable-pattern *macroexpand-hook* :lisp) + +;;; Destructuring +(define-caller-pattern destructuring-bind + (lambda-list form + (:star declaration) + (:star form)) + :lisp2) + +;;; Compiler Macros +(define-caller-pattern define-compiler-macro + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern compiler-macro-function (form) :lisp2) +(define-caller-pattern compiler-macroexpand (form (:optional :ignore)) :lisp2) +(define-caller-pattern compiler-macroexpand-1 (form (:optional :ignore)) :lisp2) + +;;; Environments +(define-caller-pattern variable-information (form &optional :ignore) + :lisp2) +(define-caller-pattern function-information (fn &optional :ignore) :lisp2) +(define-caller-pattern declaration-information (form &optional :ignore) :lisp2) +(define-caller-pattern augment-environment (form &key (:star :ignore)) :lisp2) +(define-caller-pattern define-declaration + (name + lambda-list + (:star form)) + :lisp2) +(define-caller-pattern parse-macro (name lambda-list form) :lisp2) +(define-caller-pattern enclose (form &optional :ignore) :lisp2) + + +;;; Declarations +(define-caller-pattern declare ((:rest :ignore)) :lisp) +(define-caller-pattern proclaim ((:rest :ignore)) :lisp) +(define-caller-pattern locally ((:star declaration) (:star form)) :lisp) +(define-caller-pattern declaim ((:rest :ignore)) :lisp2) +(define-caller-pattern the (form form) :lisp) + +;;; Symbols +(define-caller-pattern get (form form (:optional form)) :lisp) +(define-caller-pattern remprop (form form) :lisp) +(define-caller-pattern symbol-plist (form) :lisp) +(define-caller-pattern getf (form form (:optional form)) :lisp) +(define-caller-pattern remf (form form) :lisp) +(define-caller-pattern get-properties (form form) :lisp) + +(define-caller-pattern symbol-name (form) :lisp) +(define-caller-pattern make-symbol (form) :lisp) +(define-caller-pattern copy-symbol (form (:optional :ignore)) :lisp) +(define-caller-pattern gensym ((:optional :ignore)) :lisp) +(define-variable-pattern *gensym-counter* :lisp2) +(define-caller-pattern gentemp ((:optional :ignore :ignore)) :lisp) +(define-caller-pattern symbol-package (form) :lisp) +(define-caller-pattern keywordp (form) :lisp) + +;;; Packages +(define-variable-pattern *package* :lisp) +(define-caller-pattern make-package ((:rest :ignore)) :lisp) +(define-caller-pattern in-package ((:rest :ignore)) :lisp) +(define-caller-pattern find-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-name ((:rest :ignore)) :lisp) +(define-caller-pattern package-nicknames ((:rest :ignore)) :lisp) +(define-caller-pattern rename-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-use-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-used-by-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-shadowing-symbols ((:rest :ignore)) :lisp) +(define-caller-pattern list-all-packages () :lisp) +(define-caller-pattern delete-package ((:rest :ignore)) :lisp2) +(define-caller-pattern intern (form &optional :ignore) :lisp) +(define-caller-pattern find-symbol (form &optional :ignore) :lisp) +(define-caller-pattern unintern (form &optional :ignore) :lisp) + +(define-caller-pattern export ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern unexport ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadowing-import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadow ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) + +(define-caller-pattern use-package ((:rest :ignore)) :lisp) +(define-caller-pattern unuse-package ((:rest :ignore)) :lisp) +(define-caller-pattern defpackage (name (:rest :ignore)) :lisp2) +(define-caller-pattern find-all-symbols (form) :lisp) +(define-caller-pattern do-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-external-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-all-symbols + ((var (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern with-package-iterator + ((name form (:plus :ignore)) + (:star form)) + :lisp2) + +;;; Modules +(define-variable-pattern *modules* :lisp) +(define-caller-pattern provide (form) :lisp) +(define-caller-pattern require (form &optional :ignore) :lisp) + + +;;; Numbers +(define-caller-pattern zerop (form) :lisp) +(define-caller-pattern plusp (form) :lisp) +(define-caller-pattern minusp (form) :lisp) +(define-caller-pattern oddp (form) :lisp) +(define-caller-pattern evenp (form) :lisp) + +(define-caller-pattern = (form (:star form)) :lisp) +(define-caller-pattern /= (form (:star form)) :lisp) +(define-caller-pattern > (form (:star form)) :lisp) +(define-caller-pattern < (form (:star form)) :lisp) +(define-caller-pattern <= (form (:star form)) :lisp) +(define-caller-pattern >= (form (:star form)) :lisp) + +(define-caller-pattern max (form (:star form)) :lisp) +(define-caller-pattern min (form (:star form)) :lisp) + +(define-caller-pattern - (form (:star form)) :lisp) +(define-caller-pattern + (form (:star form)) :lisp) +(define-caller-pattern * (form (:star form)) :lisp) +(define-caller-pattern / (form (:star form)) :lisp) +(define-caller-pattern 1+ (form) :lisp) +(define-caller-pattern 1- (form) :lisp) + +(define-caller-pattern incf (form form) :lisp) +(define-caller-pattern decf (form form) :lisp) + +(define-caller-pattern conjugate (form) :lisp) + +(define-caller-pattern gcd ((:star form)) :lisp) +(define-caller-pattern lcm ((:star form)) :lisp) + +(define-caller-pattern exp (form) :lisp) +(define-caller-pattern expt (form form) :lisp) +(define-caller-pattern log (form (:optional form)) :lisp) +(define-caller-pattern sqrt (form) :lisp) +(define-caller-pattern isqrt (form) :lisp) + +(define-caller-pattern abs (form) :lisp) +(define-caller-pattern phase (form) :lisp) +(define-caller-pattern signum (form) :lisp) +(define-caller-pattern sin (form) :lisp) +(define-caller-pattern cos (form) :lisp) +(define-caller-pattern tan (form) :lisp) +(define-caller-pattern cis (form) :lisp) +(define-caller-pattern asin (form) :lisp) +(define-caller-pattern acos (form) :lisp) +(define-caller-pattern atan (form &optional form) :lisp) +(define-variable-pattern pi :lisp) + +(define-caller-pattern sinh (form) :lisp) +(define-caller-pattern cosh (form) :lisp) +(define-caller-pattern tanh (form) :lisp) +(define-caller-pattern asinh (form) :lisp) +(define-caller-pattern acosh (form) :lisp) +(define-caller-pattern atanh (form) :lisp) + +;;; Type Conversions and Extractions +(define-caller-pattern float (form (:optional form)) :lisp) +(define-caller-pattern rational (form) :lisp) +(define-caller-pattern rationalize (form) :lisp) +(define-caller-pattern numerator (form) :lisp) +(define-caller-pattern denominator (form) :lisp) + +(define-caller-pattern floor (form (:optional form)) :lisp) +(define-caller-pattern ceiling (form (:optional form)) :lisp) +(define-caller-pattern truncate (form (:optional form)) :lisp) +(define-caller-pattern round (form (:optional form)) :lisp) + +(define-caller-pattern mod (form form) :lisp) +(define-caller-pattern rem (form form) :lisp) + +(define-caller-pattern ffloor (form (:optional form)) :lisp) +(define-caller-pattern fceiling (form (:optional form)) :lisp) +(define-caller-pattern ftruncate (form (:optional form)) :lisp) +(define-caller-pattern fround (form (:optional form)) :lisp) + +(define-caller-pattern decode-float (form) :lisp) +(define-caller-pattern scale-float (form form) :lisp) +(define-caller-pattern float-radix (form) :lisp) +(define-caller-pattern float-sign (form (:optional form)) :lisp) +(define-caller-pattern float-digits (form) :lisp) +(define-caller-pattern float-precision (form) :lisp) +(define-caller-pattern integer-decode-float (form) :lisp) + +(define-caller-pattern complex (form (:optional form)) :lisp) +(define-caller-pattern realpart (form) :lisp) +(define-caller-pattern imagpart (form) :lisp) + +(define-caller-pattern logior ((:star form)) :lisp) +(define-caller-pattern logxor ((:star form)) :lisp) +(define-caller-pattern logand ((:star form)) :lisp) +(define-caller-pattern logeqv ((:star form)) :lisp) + +(define-caller-pattern lognand (form form) :lisp) +(define-caller-pattern lognor (form form) :lisp) +(define-caller-pattern logandc1 (form form) :lisp) +(define-caller-pattern logandc2 (form form) :lisp) +(define-caller-pattern logorc1 (form form) :lisp) +(define-caller-pattern logorc2 (form form) :lisp) + +(define-caller-pattern boole (form form form) :lisp) +(define-variable-pattern boole-clr :lisp) +(define-variable-pattern boole-set :lisp) +(define-variable-pattern boole-1 :lisp) +(define-variable-pattern boole-2 :lisp) +(define-variable-pattern boole-c1 :lisp) +(define-variable-pattern boole-c2 :lisp) +(define-variable-pattern boole-and :lisp) +(define-variable-pattern boole-ior :lisp) +(define-variable-pattern boole-xor :lisp) +(define-variable-pattern boole-eqv :lisp) +(define-variable-pattern boole-nand :lisp) +(define-variable-pattern boole-nor :lisp) +(define-variable-pattern boole-andc1 :lisp) +(define-variable-pattern boole-andc2 :lisp) +(define-variable-pattern boole-orc1 :lisp) +(define-variable-pattern boole-orc2 :lisp) + +(define-caller-pattern lognot (form) :lisp) +(define-caller-pattern logtest (form form) :lisp) +(define-caller-pattern logbitp (form form) :lisp) +(define-caller-pattern ash (form form) :lisp) +(define-caller-pattern logcount (form) :lisp) +(define-caller-pattern integer-length (form) :lisp) + +(define-caller-pattern byte (form form) :lisp) +(define-caller-pattern byte-size (form) :lisp) +(define-caller-pattern byte-position (form) :lisp) +(define-caller-pattern ldb (form form) :lisp) +(define-caller-pattern ldb-test (form form) :lisp) +(define-caller-pattern mask-field (form form) :lisp) +(define-caller-pattern dpb (form form form) :lisp) +(define-caller-pattern deposit-field (form form form) :lisp) + +;;; Random Numbers +(define-caller-pattern random (form (:optional form)) :lisp) +(define-variable-pattern *random-state* :lisp) +(define-caller-pattern make-random-state ((:optional form)) :lisp) +(define-caller-pattern random-state-p (form) :lisp) + +;;; Implementation Parameters +(define-variable-pattern most-positive-fixnum :lisp) +(define-variable-pattern most-negative-fixnum :lisp) +(define-variable-pattern most-positive-short-float :lisp) +(define-variable-pattern least-positive-short-float :lisp) +(define-variable-pattern least-negative-short-float :lisp) +(define-variable-pattern most-negative-short-float :lisp) +(define-variable-pattern most-positive-single-float :lisp) +(define-variable-pattern least-positive-single-float :lisp) +(define-variable-pattern least-negative-single-float :lisp) +(define-variable-pattern most-negative-single-float :lisp) +(define-variable-pattern most-positive-double-float :lisp) +(define-variable-pattern least-positive-double-float :lisp) +(define-variable-pattern least-negative-double-float :lisp) +(define-variable-pattern most-negative-double-float :lisp) +(define-variable-pattern most-positive-long-float :lisp) +(define-variable-pattern least-positive-long-float :lisp) +(define-variable-pattern least-negative-long-float :lisp) +(define-variable-pattern most-negative-long-float :lisp) +(define-variable-pattern least-positive-normalized-short-float :lisp2) +(define-variable-pattern least-negative-normalized-short-float :lisp2) +(define-variable-pattern least-positive-normalized-single-float :lisp2) +(define-variable-pattern least-negative-normalized-single-float :lisp2) +(define-variable-pattern least-positive-normalized-double-float :lisp2) +(define-variable-pattern least-negative-normalized-double-float :lisp2) +(define-variable-pattern least-positive-normalized-long-float :lisp2) +(define-variable-pattern least-negative-normalized-long-float :lisp2) +(define-variable-pattern short-float-epsilon :lisp) +(define-variable-pattern single-float-epsilon :lisp) +(define-variable-pattern double-float-epsilon :lisp) +(define-variable-pattern long-float-epsilon :lisp) +(define-variable-pattern short-float-negative-epsilon :lisp) +(define-variable-pattern single-float-negative-epsilon :lisp) +(define-variable-pattern double-float-negative-epsilon :lisp) +(define-variable-pattern long-float-negative-epsilon :lisp) + +;;; Characters +(define-variable-pattern char-code-limit :lisp) +(define-variable-pattern char-font-limit :lisp) +(define-variable-pattern char-bits-limit :lisp) +(define-caller-pattern standard-char-p (form) :lisp) +(define-caller-pattern graphic-char-p (form) :lisp) +(define-caller-pattern string-char-p (form) :lisp) +(define-caller-pattern alpha-char-p (form) :lisp) +(define-caller-pattern upper-case-p (form) :lisp) +(define-caller-pattern lower-case-p (form) :lisp) +(define-caller-pattern both-case-p (form) :lisp) +(define-caller-pattern digit-char-p (form (:optional form)) :lisp) +(define-caller-pattern alphanumericp (form) :lisp) + +(define-caller-pattern char= ((:star form)) :lisp) +(define-caller-pattern char/= ((:star form)) :lisp) +(define-caller-pattern char< ((:star form)) :lisp) +(define-caller-pattern char> ((:star form)) :lisp) +(define-caller-pattern char<= ((:star form)) :lisp) +(define-caller-pattern char>= ((:star form)) :lisp) + +(define-caller-pattern char-equal ((:star form)) :lisp) +(define-caller-pattern char-not-equal ((:star form)) :lisp) +(define-caller-pattern char-lessp ((:star form)) :lisp) +(define-caller-pattern char-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-lessp ((:star form)) :lisp) + +(define-caller-pattern char-code (form) :lisp) +(define-caller-pattern char-bits (form) :lisp) +(define-caller-pattern char-font (form) :lisp) +(define-caller-pattern code-char (form (:optional form form)) :lisp) +(define-caller-pattern make-char (form (:optional form form)) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern char-upcase (form) :lisp) +(define-caller-pattern char-downcase (form) :lisp) +(define-caller-pattern digit-char (form (:optional form form)) :lisp) +(define-caller-pattern char-int (form) :lisp) +(define-caller-pattern int-char (form) :lisp) +(define-caller-pattern char-name (form) :lisp) +(define-caller-pattern name-char (form) :lisp) +(define-variable-pattern char-control-bit :lisp) +(define-variable-pattern char-meta-bit :lisp) +(define-variable-pattern char-super-bit :lisp) +(define-variable-pattern char-hyper-bit :lisp) +(define-caller-pattern char-bit (form form) :lisp) +(define-caller-pattern set-char-bit (form form form) :lisp) + +;;; Sequences +(define-caller-pattern complement (fn) :lisp2) +(define-caller-pattern elt (form form) :lisp) +(define-caller-pattern subseq (form form &optional form) :lisp) +(define-caller-pattern copy-seq (form) :lisp) +(define-caller-pattern length (form) :lisp) +(define-caller-pattern reverse (form) :lisp) +(define-caller-pattern nreverse (form) :lisp) +(define-caller-pattern make-sequence (form form &key form) :lisp) + +(define-caller-pattern concatenate (form (:star form)) :lisp) +(define-caller-pattern map (form fn form (:star form)) :lisp) +(define-caller-pattern map-into (form fn (:star form)) :lisp2) + +(define-caller-pattern some (fn form (:star form)) :lisp) +(define-caller-pattern every (fn form (:star form)) :lisp) +(define-caller-pattern notany (fn form (:star form)) :lisp) +(define-caller-pattern notevery (fn form (:star form)) :lisp) + +(define-caller-pattern reduce (fn form &key (:star form)) :lisp) +(define-caller-pattern fill (form form &key (:star form)) :lisp) +(define-caller-pattern replace (form form &key (:star form)) :lisp) +(define-caller-pattern remove (form form &key (:star form)) :lisp) +(define-caller-pattern remove-if (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern delete (form form &key (:star form)) :lisp) +(define-caller-pattern delete-if (fn form &key (:star form)) :lisp) +(define-caller-pattern delete-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern delete-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern substitute (form form form &key (:star form)) :lisp) +(define-caller-pattern substitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern substitute-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern find (form form &key (:star form)) :lisp) +(define-caller-pattern find-if (fn form &key (:star form)) :lisp) +(define-caller-pattern find-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern position (form form &key (:star form)) :lisp) +(define-caller-pattern position-if (fn form &key (:star form)) :lisp) +(define-caller-pattern position-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern count (form form &key (:star form)) :lisp) +(define-caller-pattern count-if (fn form &key (:star form)) :lisp) +(define-caller-pattern count-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern mismatch (form form &key (:star form)) :lisp) +(define-caller-pattern search (form form &key (:star form)) :lisp) +(define-caller-pattern sort (form fn &key (:star form)) :lisp) +(define-caller-pattern stable-sort (form fn &key (:star form)) :lisp) +(define-caller-pattern merge (form form form fn &key (:star form)) :lisp) + +;;; Lists +(define-caller-pattern car (form) :lisp) +(define-caller-pattern cdr (form) :lisp) +(define-caller-pattern caar (form) :lisp) +(define-caller-pattern cadr (form) :lisp) +(define-caller-pattern cdar (form) :lisp) +(define-caller-pattern cddr (form) :lisp) +(define-caller-pattern caaar (form) :lisp) +(define-caller-pattern caadr (form) :lisp) +(define-caller-pattern cadar (form) :lisp) +(define-caller-pattern caddr (form) :lisp) +(define-caller-pattern cdaar (form) :lisp) +(define-caller-pattern cdadr (form) :lisp) +(define-caller-pattern cddar (form) :lisp) +(define-caller-pattern cdddr (form) :lisp) +(define-caller-pattern caaaar (form) :lisp) +(define-caller-pattern caaadr (form) :lisp) +(define-caller-pattern caadar (form) :lisp) +(define-caller-pattern caaddr (form) :lisp) +(define-caller-pattern cadaar (form) :lisp) +(define-caller-pattern cadadr (form) :lisp) +(define-caller-pattern caddar (form) :lisp) +(define-caller-pattern cadddr (form) :lisp) +(define-caller-pattern cdaaar (form) :lisp) +(define-caller-pattern cdaadr (form) :lisp) +(define-caller-pattern cdadar (form) :lisp) +(define-caller-pattern cdaddr (form) :lisp) +(define-caller-pattern cddaar (form) :lisp) +(define-caller-pattern cddadr (form) :lisp) +(define-caller-pattern cdddar (form) :lisp) +(define-caller-pattern cddddr (form) :lisp) + +(define-caller-pattern cons (form form) :lisp) +(define-caller-pattern tree-equal (form form &key (:star fn)) :lisp) +(define-caller-pattern endp (form) :lisp) +(define-caller-pattern list-length (form) :lisp) +(define-caller-pattern nth (form form) :lisp) + +(define-caller-pattern first (form) :lisp) +(define-caller-pattern second (form) :lisp) +(define-caller-pattern third (form) :lisp) +(define-caller-pattern fourth (form) :lisp) +(define-caller-pattern fifth (form) :lisp) +(define-caller-pattern sixth (form) :lisp) +(define-caller-pattern seventh (form) :lisp) +(define-caller-pattern eighth (form) :lisp) +(define-caller-pattern ninth (form) :lisp) +(define-caller-pattern tenth (form) :lisp) + +(define-caller-pattern rest (form) :lisp) +(define-caller-pattern nthcdr (form form) :lisp) +(define-caller-pattern last (form (:optional form)) :lisp) +(define-caller-pattern list ((:star form)) :lisp) +(define-caller-pattern list* ((:star form)) :lisp) +(define-caller-pattern make-list (form &key (:star form)) :lisp) +(define-caller-pattern append ((:star form)) :lisp) +(define-caller-pattern copy-list (form) :lisp) +(define-caller-pattern copy-alist (form) :lisp) +(define-caller-pattern copy-tree (form) :lisp) +(define-caller-pattern revappend (form form) :lisp) +(define-caller-pattern nconc ((:star form)) :lisp) +(define-caller-pattern nreconc (form form) :lisp) +(define-caller-pattern push (form form) :lisp) +(define-caller-pattern pushnew (form form &key (:star form)) :lisp) +(define-caller-pattern pop (form) :lisp) +(define-caller-pattern butlast (form (:optional form)) :lisp) +(define-caller-pattern nbutlast (form (:optional form)) :lisp) +(define-caller-pattern ldiff (form form) :lisp) +(define-caller-pattern rplaca (form form) :lisp) +(define-caller-pattern rplacd (form form) :lisp) + +(define-caller-pattern subst (form form form &key (:star form)) :lisp) +(define-caller-pattern subst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern subst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern sublis (form form &key (:star form)) :lisp) +(define-caller-pattern nsublis (form form &key (:star form)) :lisp) +(define-caller-pattern member (form form &key (:star form)) :lisp) +(define-caller-pattern member-if (fn form &key (:star form)) :lisp) +(define-caller-pattern member-if-not (fn form &key (:star form)) :lisp) + +(define-caller-pattern tailp (form form) :lisp) +(define-caller-pattern adjoin (form form &key (:star form)) :lisp) +(define-caller-pattern union (form form &key (:star form)) :lisp) +(define-caller-pattern nunion (form form &key (:star form)) :lisp) +(define-caller-pattern intersection (form form &key (:star form)) :lisp) +(define-caller-pattern nintersection (form form &key (:star form)) :lisp) +(define-caller-pattern set-difference (form form &key (:star form)) :lisp) +(define-caller-pattern nset-difference (form form &key (:star form)) :lisp) +(define-caller-pattern set-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern nset-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern subsetp (form form &key (:star form)) :lisp) + +(define-caller-pattern acons (form form form) :lisp) +(define-caller-pattern pairlis (form form (:optional form)) :lisp) +(define-caller-pattern assoc (form form &key (:star form)) :lisp) +(define-caller-pattern assoc-if (fn form) :lisp) +(define-caller-pattern assoc-if-not (fn form) :lisp) +(define-caller-pattern rassoc (form form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if (fn form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if-not (fn form &key (:star form)) :lisp) + +;;; Hash Tables +(define-caller-pattern make-hash-table (&key (:star form)) :lisp) +(define-caller-pattern hash-table-p (form) :lisp) +(define-caller-pattern gethash (form form (:optional form)) :lisp) +(define-caller-pattern remhash (form form) :lisp) +(define-caller-pattern maphash (fn form) :lisp) +(define-caller-pattern clrhash (form) :lisp) +(define-caller-pattern hash-table-count (form) :lisp) +(define-caller-pattern with-hash-table-iterator + ((name form) (:star form)) :lisp2) +(define-caller-pattern hash-table-rehash-size (form) :lisp2) +(define-caller-pattern hash-table-rehash-threshold (form) :lisp2) +(define-caller-pattern hash-table-size (form) :lisp2) +(define-caller-pattern hash-table-test (form) :lisp2) +(define-caller-pattern sxhash (form) :lisp) + +;;; Arrays +(define-caller-pattern make-array (form &key (:star form)) :lisp) +(define-variable-pattern array-rank-limit :lisp) +(define-variable-pattern array-dimension-limit :lisp) +(define-variable-pattern array-total-size-limit :lisp) +(define-caller-pattern vector ((:star form)) :lisp) +(define-caller-pattern aref (form (:star form)) :lisp) +(define-caller-pattern svref (form form) :lisp) +(define-caller-pattern array-element-type (form) :lisp) +(define-caller-pattern array-rank (form) :lisp) +(define-caller-pattern array-dimension (form form) :lisp) +(define-caller-pattern array-dimensions (form) :lisp) +(define-caller-pattern array-total-size (form) :lisp) +(define-caller-pattern array-in-bounds-p (form (:star form)) :lisp) +(define-caller-pattern array-row-major-index (form (:star form)) :lisp) +(define-caller-pattern row-major-aref (form form) :lisp2) +(define-caller-pattern adjustable-array-p (form) :lisp) + +(define-caller-pattern bit (form (:star form)) :lisp) +(define-caller-pattern sbit (form (:star form)) :lisp) + +(define-caller-pattern bit-and (form form (:optional form)) :lisp) +(define-caller-pattern bit-ior (form form (:optional form)) :lisp) +(define-caller-pattern bit-xor (form form (:optional form)) :lisp) +(define-caller-pattern bit-eqv (form form (:optional form)) :lisp) +(define-caller-pattern bit-nand (form form (:optional form)) :lisp) +(define-caller-pattern bit-nor (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-not (form (:optional form)) :lisp) + +(define-caller-pattern array-has-fill-pointer-p (form) :lisp) +(define-caller-pattern fill-pointer (form) :lisp) +(define-caller-pattern vector-push (form form) :lisp) +(define-caller-pattern vector-push-extend (form form (:optional form)) :lisp) +(define-caller-pattern vector-pop (form) :lisp) +(define-caller-pattern adjust-array (form form &key (:star form)) :lisp) + +;;; Strings +(define-caller-pattern char (form form) :lisp) +(define-caller-pattern schar (form form) :lisp) +(define-caller-pattern string= (form form &key (:star form)) :lisp) +(define-caller-pattern string-equal (form form &key (:star form)) :lisp) +(define-caller-pattern string< (form form &key (:star form)) :lisp) +(define-caller-pattern string> (form form &key (:star form)) :lisp) +(define-caller-pattern string<= (form form &key (:star form)) :lisp) +(define-caller-pattern string>= (form form &key (:star form)) :lisp) +(define-caller-pattern string/= (form form &key (:star form)) :lisp) +(define-caller-pattern string-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-equal (form form &key (:star form)) :lisp) + +(define-caller-pattern make-string (form &key (:star form)) :lisp) +(define-caller-pattern string-trim (form form) :lisp) +(define-caller-pattern string-left-trim (form form) :lisp) +(define-caller-pattern string-right-trim (form form) :lisp) +(define-caller-pattern string-upcase (form &key (:star form)) :lisp) +(define-caller-pattern string-downcase (form &key (:star form)) :lisp) +(define-caller-pattern string-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern nstring-upcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-downcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern string (form) :lisp) + +;;; Structures +(define-caller-pattern defstruct + ((:or name (name (:rest :ignore))) + (:optional documentation-string) + (:plus :ignore)) + :lisp) + +;;; The Evaluator +(define-caller-pattern eval (form) :lisp) +(define-variable-pattern *evalhook* :lisp) +(define-variable-pattern *applyhook* :lisp) +(define-caller-pattern evalhook (form fn fn &optional :ignore) :lisp) +(define-caller-pattern applyhook (fn form fn fn &optional :ignore) :lisp) +(define-caller-pattern constantp (form) :lisp) + +;;; Streams +(define-variable-pattern *standard-input* :lisp) +(define-variable-pattern *standard-output* :lisp) +(define-variable-pattern *error-output* :lisp) +(define-variable-pattern *query-io* :lisp) +(define-variable-pattern *debug-io* :lisp) +(define-variable-pattern *terminal-io* :lisp) +(define-variable-pattern *trace-output* :lisp) +(define-caller-pattern make-synonym-stream (symbol) :lisp) +(define-caller-pattern make-broadcast-stream ((:star form)) :lisp) +(define-caller-pattern make-concatenated-stream ((:star form)) :lisp) +(define-caller-pattern make-two-way-stream (form form) :lisp) +(define-caller-pattern make-echo-stream (form form) :lisp) +(define-caller-pattern make-string-input-stream (form &optional form form) :lisp) +(define-caller-pattern make-string-output-stream (&key (:star form)) :lisp) +(define-caller-pattern get-output-stream-string (form) :lisp) + +(define-caller-pattern with-open-stream + ((var form) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-input-from-string + ((var form &key (:star form)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-output-to-string + ((var (:optional form)) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern streamp (form) :lisp) +(define-caller-pattern open-stream-p (form) :lisp2) +(define-caller-pattern input-stream-p (form) :lisp) +(define-caller-pattern output-stream-p (form) :lisp) +(define-caller-pattern stream-element-type (form) :lisp) +(define-caller-pattern close (form (:rest :ignore)) :lisp) +(define-caller-pattern broadcast-stream-streams (form) :lisp2) +(define-caller-pattern concatenated-stream-streams (form) :lisp2) +(define-caller-pattern echo-stream-input-stream (form) :lisp2) +(define-caller-pattern echo-stream-output-stream (form) :lisp2) +(define-caller-pattern synonym-stream-symbol (form) :lisp2) +(define-caller-pattern two-way-stream-input-stream (form) :lisp2) +(define-caller-pattern two-way-stream-output-stream (form) :lisp2) +(define-caller-pattern interactive-stream-p (form) :lisp2) +(define-caller-pattern stream-external-format (form) :lisp2) + +;;; Reader +(define-variable-pattern *read-base* :lisp) +(define-variable-pattern *read-suppress* :lisp) +(define-variable-pattern *read-eval* :lisp2) +(define-variable-pattern *readtable* :lisp) +(define-caller-pattern copy-readtable (&optional form form) :lisp) +(define-caller-pattern readtablep (form) :lisp) +(define-caller-pattern set-syntax-from-char (form form &optional form form) :lisp) +(define-caller-pattern set-macro-character (form fn &optional form) :lisp) +(define-caller-pattern get-macro-character (form (:optional form)) :lisp) +(define-caller-pattern make-dispatch-macro-character (form &optional form form) + :lisp) +(define-caller-pattern set-dispatch-macro-character + (form form fn (:optional form)) :lisp) +(define-caller-pattern get-dispatch-macro-character + (form form (:optional form)) :lisp) +(define-caller-pattern readtable-case (form) :lisp2) +(define-variable-pattern *print-readably* :lisp2) +(define-variable-pattern *print-escape* :lisp) +(define-variable-pattern *print-pretty* :lisp) +(define-variable-pattern *print-circle* :lisp) +(define-variable-pattern *print-base* :lisp) +(define-variable-pattern *print-radix* :lisp) +(define-variable-pattern *print-case* :lisp) +(define-variable-pattern *print-gensym* :lisp) +(define-variable-pattern *print-level* :lisp) +(define-variable-pattern *print-length* :lisp) +(define-variable-pattern *print-array* :lisp) +(define-caller-pattern with-standard-io-syntax + ((:star declaration) + (:star form)) + :lisp2) + +(define-caller-pattern read (&optional form form form form) :lisp) +(define-variable-pattern *read-default-float-format* :lisp) +(define-caller-pattern read-preserving-whitespace + (&optional form form form form) :lisp) +(define-caller-pattern read-delimited-list (form &optional form form) :lisp) +(define-caller-pattern read-line (&optional form form form form) :lisp) +(define-caller-pattern read-char (&optional form form form form) :lisp) +(define-caller-pattern unread-char (form (:optional form)) :lisp) +(define-caller-pattern peek-char (&optional form form form form) :lisp) +(define-caller-pattern listen ((:optional form)) :lisp) +(define-caller-pattern read-char-no-hang ((:star form)) :lisp) +(define-caller-pattern clear-input ((:optional form)) :lisp) +(define-caller-pattern read-from-string (form (:star form)) :lisp) +(define-caller-pattern parse-integer (form &rest :ignore) :lisp) +(define-caller-pattern read-byte ((:star form)) :lisp) + +(define-caller-pattern write (form &key (:star form)) :lisp) +(define-caller-pattern prin1 (form (:optional form)) :lisp) +(define-caller-pattern print (form (:optional form)) :lisp) +(define-caller-pattern pprint (form (:optional form)) :lisp) +(define-caller-pattern princ (form (:optional form)) :lisp) +(define-caller-pattern write-to-string (form &key (:star form)) :lisp) +(define-caller-pattern prin1-to-string (form) :lisp) +(define-caller-pattern princ-to-string (form) :lisp) +(define-caller-pattern write-char (form (:optional form)) :lisp) +(define-caller-pattern write-string (form &optional form &key (:star form)) :lisp) +(define-caller-pattern write-line (form &optional form &key (:star form)) :lisp) +(define-caller-pattern terpri ((:optional form)) :lisp) +(define-caller-pattern fresh-line ((:optional form)) :lisp) +(define-caller-pattern finish-output ((:optional form)) :lisp) +(define-caller-pattern force-output ((:optional form)) :lisp) +(define-caller-pattern clear-output ((:optional form)) :lisp) +(define-caller-pattern print-unreadable-object + ((form form &key (:star form)) + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern write-byte (form form) :lisp) +(define-caller-pattern format + (destination + control-string + (:rest format-arguments)) + :lisp) + +(define-caller-pattern y-or-n-p (control-string (:star form)) :lisp) +(define-caller-pattern yes-or-no-p (control-string (:star form)) :lisp) + +;;; Pathnames +(define-caller-pattern wild-pathname-p (form &optional form) :lisp2) +(define-caller-pattern pathname-match-p (form form) :lisp2) +(define-caller-pattern translate-pathname (form form form &key (:star form)) + :lisp2) + +(define-caller-pattern logical-pathname (form) :lisp2) +(define-caller-pattern translate-logical-pathname (form &key (:star form)) :lisp2) +(define-caller-pattern logical-pathname-translations (form) :lisp2) +(define-caller-pattern load-logical-pathname-translations (form) :lisp2) +(define-caller-pattern compile-file-pathname (form &key form) :lisp2) + +(define-caller-pattern pathname (form) :lisp) +(define-caller-pattern truename (form) :lisp) +(define-caller-pattern parse-namestring ((:star form)) :lisp) +(define-caller-pattern merge-pathnames ((:star form)) :lisp) +(define-variable-pattern *default-pathname-defaults* :lisp) +(define-caller-pattern make-pathname ((:star form)) :lisp) +(define-caller-pattern pathnamep (form) :lisp) +(define-caller-pattern pathname-host (form) :lisp) +(define-caller-pattern pathname-device (form) :lisp) +(define-caller-pattern pathname-directory (form) :lisp) +(define-caller-pattern pathname-name (form) :lisp) +(define-caller-pattern pathname-type (form) :lisp) +(define-caller-pattern pathname-version (form) :lisp) +(define-caller-pattern namestring (form) :lisp) +(define-caller-pattern file-namestring (form) :lisp) +(define-caller-pattern directory-namestring (form) :lisp) +(define-caller-pattern host-namestring (form) :lisp) +(define-caller-pattern enough-namestring (form (:optional form)) :lisp) +(define-caller-pattern user-homedir-pathname (&optional form) :lisp) +(define-caller-pattern open (form &key (:star form)) :lisp) +(define-caller-pattern with-open-file + ((var form (:rest :ignore)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern rename-file (form form) :lisp) +(define-caller-pattern delete-file (form) :lisp) +(define-caller-pattern probe-file (form) :lisp) +(define-caller-pattern file-write-date (form) :lisp) +(define-caller-pattern file-author (form) :lisp) +(define-caller-pattern file-position (form (:optional form)) :lisp) +(define-caller-pattern file-length (form) :lisp) +(define-caller-pattern file-string-length (form form) :lisp2) +(define-caller-pattern load (form &key (:star form)) :lisp) +(define-variable-pattern *load-verbose* :lisp) +(define-variable-pattern *load-print* :lisp2) +(define-variable-pattern *load-pathname* :lisp2) +(define-variable-pattern *load-truename* :lisp2) +(define-caller-pattern make-load-form (form) :lisp2) +(define-caller-pattern make-load-form-saving-slots (form &optional form) + :lisp2) +(define-caller-pattern directory (form &key (:star form)) :lisp) + +;;; Errors +(define-caller-pattern error (form (:star form)) :lisp) +(define-caller-pattern cerror (form form (:star form)) :lisp) +(define-caller-pattern warn (form (:star form)) :lisp) +(define-variable-pattern *break-on-warnings* :lisp) +(define-caller-pattern break (&optional form (:star form)) :lisp) +(define-caller-pattern check-type (form form (:optional form)) :lisp) +(define-caller-pattern assert + (form + (:optional ((:star var)) + (:optional form (:star form)))) + :lisp) +(define-caller-pattern etypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ctypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ecase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern ccase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) + +;;; The Compiler +(define-caller-pattern compile (form (:optional form)) :lisp) +(define-caller-pattern compile-file (form &key (:star form)) :lisp) +(define-variable-pattern *compile-verbose* :lisp2) +(define-variable-pattern *compile-print* :lisp2) +(define-variable-pattern *compile-file-pathname* :lisp2) +(define-variable-pattern *compile-file-truename* :lisp2) +(define-caller-pattern load-time-value (form (:optional form)) :lisp2) +(define-caller-pattern disassemble (form) :lisp) +(define-caller-pattern function-lambda-expression (fn) :lisp2) +(define-caller-pattern with-compilation-unit (((:star :ignore)) (:star form)) + :lisp2) + +;;; Documentation +(define-caller-pattern documentation (form form) :lisp) +(define-caller-pattern trace ((:star form)) :lisp) +(define-caller-pattern untrace ((:star form)) :lisp) +(define-caller-pattern step (form) :lisp) +(define-caller-pattern time (form) :lisp) +(define-caller-pattern describe (form &optional form) :lisp) +(define-caller-pattern describe-object (form &optional form) :lisp2) +(define-caller-pattern inspect (form) :lisp) +(define-caller-pattern room ((:optional form)) :lisp) +(define-caller-pattern ed ((:optional form)) :lisp) +(define-caller-pattern dribble ((:optional form)) :lisp) +(define-caller-pattern apropos (form (:optional form)) :lisp) +(define-caller-pattern apropos-list (form (:optional form)) :lisp) +(define-caller-pattern get-decoded-time () :lisp) +(define-caller-pattern get-universal-time () :lisp) +(define-caller-pattern decode-universal-time (form &optional form) :lisp) +(define-caller-pattern encode-universal-time + (form form form form form form &optional form) :lisp) +(define-caller-pattern get-internal-run-time () :lisp) +(define-caller-pattern get-internal-real-time () :lisp) +(define-caller-pattern sleep (form) :lisp) + +(define-caller-pattern lisp-implementation-type () :lisp) +(define-caller-pattern lisp-implementation-version () :lisp) +(define-caller-pattern machine-type () :lisp) +(define-caller-pattern machine-version () :lisp) +(define-caller-pattern machine-instance () :lisp) +(define-caller-pattern software-type () :lisp) +(define-caller-pattern software-version () :lisp) +(define-caller-pattern short-site-name () :lisp) +(define-caller-pattern long-site-name () :lisp) +(define-variable-pattern *features* :lisp) + +(define-caller-pattern identity (form) :lisp) + +;;; Pretty Printing +(define-variable-pattern *print-pprint-dispatch* :lisp2) +(define-variable-pattern *print-right-margin* :lisp2) +(define-variable-pattern *print-miser-width* :lisp2) +(define-variable-pattern *print-lines* :lisp2) +(define-caller-pattern pprint-newline (form &optional form) :lisp2) +(define-caller-pattern pprint-logical-block + ((var form &key (:star form)) + (:star form)) + :lisp2) +(define-caller-pattern pprint-exit-if-list-exhausted () :lisp2) +(define-caller-pattern pprint-pop () :lisp2) +(define-caller-pattern pprint-indent (form form &optional form) :lisp2) +(define-caller-pattern pprint-tab (form form form &optional form) :lisp2) +(define-caller-pattern pprint-fill (form form &optional form form) :lisp2) +(define-caller-pattern pprint-linear (form form &optional form form) :lisp2) +(define-caller-pattern pprint-tabular (form form &optional form form form) :lisp2) +(define-caller-pattern formatter (control-string) :lisp2) +(define-caller-pattern copy-pprint-dispatch (&optional form) :lisp2) +(define-caller-pattern pprint-dispatch (form &optional form) :lisp2) +(define-caller-pattern set-pprint-dispatch (form form &optional form form) + :lisp2) + +;;; CLOS +(define-caller-pattern add-method (fn form) :lisp2) +(define-caller-pattern call-method (form form) :lisp2) +(define-caller-pattern call-next-method ((:star form)) :lisp2) +(define-caller-pattern change-class (form form) :lisp2) +(define-caller-pattern class-name (form) :lisp2) +(define-caller-pattern class-of (form) :lisp2) +(define-caller-pattern compute-applicable-methods (fn (:star form)) :lisp2) +(define-caller-pattern defclass (name &rest :ignore) :lisp2) +(define-caller-pattern defgeneric (name lambda-list &rest :ignore) :lisp2) +(define-caller-pattern define-method-combination + (name lambda-list ((:star :ignore)) + (:optional ((:eq :arguments) :ignore)) + (:optional ((:eq :generic-function) :ignore)) + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern defmethod + (name (:star symbol) lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern ensure-generic-function (name &key (:star form)) :lisp2) +(define-caller-pattern find-class (form &optional form form) :lisp2) +(define-caller-pattern find-method (fn &rest :ignore) :lisp2) +(define-caller-pattern function-keywords (&rest :ignore) :lisp2) +(define-caller-pattern generic-flet (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-labels + (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-function (lambda-list) :lisp2) +(define-caller-pattern initialize-instance (form &key (:star form)) :lisp2) +(define-caller-pattern invalid-method-error (fn form (:star form)) :lisp2) +(define-caller-pattern make-instance (fn (:star form)) :lisp2) +(define-caller-pattern make-instances-obsolete (fn) :lisp2) +(define-caller-pattern method-combination-error (form (:star form)) :lisp2) +(define-caller-pattern method-qualifiers (fn) :lisp2) +(define-caller-pattern next-method-p () :lisp2) +(define-caller-pattern no-applicable-method (fn (:star form)) :lisp2) +(define-caller-pattern no-next-method (fn (:star form)) :lisp2) +(define-caller-pattern print-object (form form) :lisp2) +(define-caller-pattern reinitialize-instance (form (:star form)) :lisp2) +(define-caller-pattern remove-method (fn form) :lisp2) +(define-caller-pattern shared-initialize (form form (:star form)) :lisp2) +(define-caller-pattern slot-boundp (form form) :lisp2) +(define-caller-pattern slot-exists-p (form form) :lisp2) +(define-caller-pattern slot-makeunbound (form form) :lisp2) +(define-caller-pattern slot-missing (fn form form form &optional form) :lisp2) +(define-caller-pattern slot-unbound (fn form form) :lisp2) +(define-caller-pattern slot-value (form form) :lisp2) +(define-caller-pattern update-instance-for-different-class + (form form (:star form)) :lisp2) +(define-caller-pattern update-instance-for-redefined-class + (form form (:star form)) :lisp2) +(define-caller-pattern with-accessors + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern with-added-methods + ((name lambda-list) form + (:star form)) + :lisp2) +(define-caller-pattern with-slots + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) + +;;; Conditions +(define-caller-pattern signal (form (:star form)) :lisp2) +(define-variable-pattern *break-on-signals* :lisp2) +(define-caller-pattern handler-case (form (:star (form ((:optional var)) + (:star form)))) + :lisp2) +(define-caller-pattern ignore-errors ((:star form)) :lisp2) +(define-caller-pattern handler-bind (((:star (form form))) + (:star form)) + :lisp2) +(define-caller-pattern define-condition (name &rest :ignore) :lisp2) +(define-caller-pattern make-condition (form &rest :ignore) :lisp2) +(define-caller-pattern with-simple-restart + ((name form (:star form)) (:star form)) :lisp2) +(define-caller-pattern restart-case + (form + (:star (form form (:star form)))) + :lisp2) +(define-caller-pattern restart-bind + (((:star (name fn &key (:star form)))) + (:star form)) + :lisp2) +(define-caller-pattern with-condition-restarts + (form form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern compute-restarts (&optional form) :lisp2) +(define-caller-pattern restart-name (form) :lisp2) +(define-caller-pattern find-restart (form &optional form) :lisp2) +(define-caller-pattern invoke-restart (form (:star form)) :lisp2) +(define-caller-pattern invoke-restart-interactively (form) :lisp2) +(define-caller-pattern abort (&optional form) :lisp2) +(define-caller-pattern continue (&optional form) :lisp2) +(define-caller-pattern muffle-warning (&optional form) :lisp2) +(define-caller-pattern store-value (form &optional form) :lisp2) +(define-caller-pattern use-value (form &optional form) :lisp2) +(define-caller-pattern invoke-debugger (form) :lisp2) +(define-variable-pattern *debugger-hook* :lisp2) +(define-caller-pattern simple-condition-format-string (form) :lisp2) +(define-caller-pattern simple-condition-format-arguments (form) :lisp2) +(define-caller-pattern type-error-datum (form) :lisp2) +(define-caller-pattern type-error-expected-type (form) :lisp2) +(define-caller-pattern package-error-package (form) :lisp2) +(define-caller-pattern stream-error-stream (form) :lisp2) +(define-caller-pattern file-error-pathname (form) :lisp2) +(define-caller-pattern cell-error-name (form) :lisp2) +(define-caller-pattern arithmetic-error-operation (form) :lisp2) +(define-caller-pattern arithmetic-error-operands (form) :lisp2) + +;;; For ZetaLisp Flavors +(define-caller-pattern send (form fn (:star form)) :flavors)